Pascal Super Library/Pascal Super Library (CW International)(1997).bin/TIPS/SWTIP/SWTIP

Text File | 1994-07-02 | 150KB | 6,058 lines

{!compiler.inc!}
{$A+,B-,D-,E-,F-,G-,I+,L-,N-,O-,R-,S-,V+,X- Borland's Turbo Pascal}
{$ifdef VER70}{$P-,Q-,T+}{$endif}
{$M 65520,0,655360 memory}
{$D+,L+ debugger}
{$B+,R+,S+ run time}{$ifdef VER70}{*$Q+}{$endif}
{!header.p!}
{
    Source code from the book
    "Software Tools in Pascal", by
    Brian W. Kernighan and P.J. Plauger
    Addison-Wesley, 1981
    ISBN 0-201-10342-7

  Copyright (c) 1981
  By:  Bell Telephone Laboratories, Incorporated, and
       Whitesmith's, Ltd.
}

{!copyz.p!}
{ copyz -- copy input to output }
  procedure COPYZ;
  var
    C : CHARACTER;
  begin
    while (GETC(C) <> ENDFILE) do
      PUTC(C)
  end;

{!copyprog.pas!}
{ complete copy -- to show one possible implementation }
program COPYPROG(Input, Output);
const
  ENDFILE = -1;
  NEWLINE = 10;                 { ASCII value }
type
  CHARACTER = -1..127;          { ASCII, plus ENDFILE }

  { getc -- get one character from standard input }
  function GETC(var C : CHARACTER) : CHARACTER;
  var
    CH : Char;
  begin
    if (Eof) then
      C := ENDFILE
    else if (Eoln) then
      begin
        ReadLn;
        C := NEWLINE;
      end
    else
      begin
        Read(CH);
        C := Ord(CH);
      end;
    GETC := C;
  end;

  { putc -- put one character on standard output }
  procedure PUTC(C : CHARACTER);
  begin
    if (C = NEWLINE) then
      WriteLn
    else
      Write(Chr(C));
  end;

  { copyz -- copy input to output }
  procedure COPYZ;
  var
    C : CHARACTER;
  begin
    while (GETC(C) <> ENDFILE) do
      PUTC(C)
  end;

begin                           { main program }
  COPYZ
end.

{!charcnt.p!}
  { charcount -- count characters in standard input }
  procedure CHARCOUNT;
  var
    NC : Integer;
    C : CHARACTER;
  begin
    NC := 0;
    while (GETC(C) <> ENDFILE) do
      NC := NC+1;
    PUTDEC(NC, 1);
    PUTC(NEWLINE)
  end;

{!linecnt.p!}
  { linecount -- count lines in standard input }
  procedure LINECOUNT;
  var
    N1 : Integer;
    C : CHARACTER;
  begin
    N1 := 0;
    while (GETC(C) <> ENDFILE) do
      if (C = NEWLINE) then
        N1 := N1+1;
    PUTDEC(N1, 1);
    PUTC(NEWLINE)
  end;

{!wordcnt.p!}
  { wordcount -- count words in standard input }
  procedure WORDCOUNT;
  var
    NW : Integer;
    C : CHARACTER;
    INWORD : Boolean;
  begin
    NW := 0;
    INWORD := False;
    while (GETC(C) <> ENDFILE) do
      if ((C = BLANK) or
          (C = NEWLINE) or
          (C = TAB)) then
        INWORD := False
      else if (not INWORD) then
        begin
          INWORD := True;
          NW := NW+1;
        end;
    PUTDEC(NW, 1);
    PUTC(NEWLINE)
  end;

{!detab.p!}
  { detab -- convert tabs to equivalent number of blanks }
  procedure DETAB;
  const
    MAXLINE = 1000;             { or whatever }
  type
    TABTYPE = array[1..MAXLINE] of Boolean;
  var
    C : CHARACTER;
    COL : Integer;
    TABSTOPS : TABTYPE;

#include "tabpos.p"
#include "settabs.p"
  begin
    SETTABS(TABSTOPS);          { set initial tab stops }
    COL := 1;
    while (GETC(C) <> ENDFILE) do
      if (C = TAB) then
        repeat
          PUTC(BLANK);
          COL := COL+1
        until (TABPOS(COL, TABSTOPS))
      else if (C = NEWLINE) then
        begin
          PUTC(NEWLINE);
          COL := 1
        end
      else
        begin
          PUTC(C);
          COL := COL+1
        end
  end;

{!tabpos.p!}
  { tabpos -- return true if col is a tab stop }
  function TABPOS(COL : Integer;
                  var TABSTOPS : TABTYPE) : Boolean;
  begin
    if (COL > MAXLINE) then
      TABPOS := True
    else
      TABPOS := TABSTOPS[COL]
  end;

{!settabs.p!}
  { settabs -- set initial tab stops }
  procedure SETTABS(var TABSTOPS : TABTYPE);
  const
    TABSPACE = 8;               { 8 spaces per tab }
  var
    I : Integer;
  begin
    for I := 1 to MAXLINE do
      TABSTOPS[I] := (I mod TABSPACE = 1)
  end;

{!entab.p!}
  { entab -- replace blanks by tabs and blanks }
  procedure ENTAB;
  const
    MAXLINE = 1000;             { or whatever }
  type
    TABTYPE = array[1..MAXLINE] of Boolean;
  var
    C : CHARACTER;
    COL, NEWCOL : Integer;
    TABSTOPS : TABTYPE;

#include "tabpos.p"
#include "settabs.p"
  begin
    SETTABS(TABSTOPS);
    COL := 1;
    repeat
      NEWCOL := COL;
      while (GETC(C) = BLANK) do { collect blanks }
        begin
          NEWCOL := NEWCOL+1;
          if (TABPOS(NEWCOL, TABSTOPS)) then
            begin
              PUTC(TAB);
              COL := NEWCOL
            end
        end;
      while (COL < NEWCOL) do
        begin
          PUTC(BLANK);          { output leftover blanks }
          COL := COL+1
        end;
      if (C <> ENDFILE) then
        begin
          PUTC(C);
          if (C = NEWLINE) then
            COL := 1
          else
            COL := COL+1
        end
    until (C = ENDFILE)
  end;

{!overstrk.p!}
  { overstrike -- convert backspaces into multiple lines }
  procedure OVERSTRIKE;
  const
    SKIP = BLANK;
    NOSKIP = PLUS;
  var
    C : CHARACTER;
    COL, NEWCOL, I : Integer;
  begin
    COL := 1;
    repeat
      NEWCOL := COL;
      while (GETC(C) = BACKSPACE) do { eat backspaces}
        NEWCOL := MAX(NEWCOL-1, 1);
      if (NEWCOL < COL) then
        begin
          PUTC(NEWLINE);        { start overstrike line }
          PUTC(NOSKIP);
          for I := 1 to NEWCOL-1 do
            PUTC(BLANK);
          COL := NEWCOL
        end
      else if ((COL = 1) and
               (C <> ENDFILE)) then
        PUTC(SKIP);             { normal line }
      { else middle of line }
      if (C <> ENDFILE) then
        begin
          PUTC(C);              { normal character}
          if (C = NEWLINE) then
            COL := 1
          else
            COL := COL+1
        end
    until (C = ENDFILE)
  end;

{!max.p!}
  { max -- compute maximum of two integers }
  function MAX(X, Y : Integer) : Integer;
  begin
    if (X > Y) then
      MAX := X
    else
      MAX := Y
  end;

{!compress.p!}
  { compress -- compress standard input }
  procedure COMPRESS;
  const
    WARNING = TILDE;            { ~ }
  var
    C, LASTC : CHARACTER;
    N : Integer;

#include "putrep.p"
  begin
    N := 1;
    LASTC := GETC(LASTC);
    while (LASTC <> ENDFILE) do
      begin
        if (GETC(C) = ENDFILE) then
          begin
            if ((N > 1) or
                (LASTC = WARNING)) then
              PUTREP(N, LASTC)
            else
              PUTC(LASTC)
          end
        else if (C = LASTC) then
          N := N+1
        else if ((N > 1) or
                 (LASTC = WARNING)) then
          begin
            PUTREP(N, LASTC);
            N := 1
          end
        else
          PUTC(LASTC);
        LASTC := C
      end
  end;

{!putrep.p!}
  { putrep -- put out representation of run of n 'c's }
  procedure PUTREP(N : Integer;
                   C : CHARACTER);
  const
    MAXREP = 26;                { assuming 'A'..'Z' }
    THRESH = 4;
  begin
    while ((N >= THRESH) or
           ((C = WARNING) and
            (N > 0))) do
      begin
        PUTC(WARNING);
        PUTC(MIN(N, MAXREP)-1+Ord('A'));
        PUTC(C);
        N := N-MAXREP
      end;
    for N := N downto 1 do
      PUTC(C)
  end;

{!min.p!}
  { min -- compute minimum of two integers }
  function MIN(X, Y : Integer) : Integer;
  begin
    if (X < Y) then
      MIN := X
    else
      MIN := Y
  end;

{!expand.p!}
  { expand -- uncompress standard input }
  procedure EXPAND;
  const
    WARNING = TILDE;            { ~ }
  var
    C : CHARACTER;
    N : Integer;
  begin
    while (GETC(C) <> ENDFILE) do
      if (C <> WARNING) then
        PUTC(C)
      else if (ISUPPER(GETC(C))) then
        begin
          N := C-Ord('A')+1;
          if (GETC(C) <> ENDFILE) then
            for N := N downto 1 do
              PUTC(C)
          else
            begin
              PUTC(WARNING);
              PUTC(N-1+Ord('A'))
            end
        end
      else
        begin
          PUTC(WARNING);
          if (C <> ENDFILE) then
            PUTC(C)
        end
  end;

{!isupper.p!}
  { isupper -- true if c is upper case letter }
  function ISUPPER(C : CHARACTER) : Boolean;
  begin
    ISUPPER := C in [Ord('A') ..Ord('Z')]
  end;

{!echo.p!}
  { echo -- echo command line arguments to output }
  procedure ECHO;
  var
    I, J : Integer;
    ARGSTR : STRINGZ;
  begin
    I := 1;
    while (GETARG(I, ARGSTR, MAXSTR)) do
      begin
        if (I > 1) then PUTC(BLANK);
        for J := 1 to LENGTHZ(ARGSTR) do
          PUTC(ARGSTR[J]);
        I := I+1
      end;
    if (I > 1) then
      PUTC(NEWLINE)
  end;

{!lengthz.p!}
  { lengthz -- compute the length of stringz }
  function LENGTHZ(var S : STRINGZ) : Integer;
  var
    N : Integer;
  begin
    N := 1;
    while (S[N] <> ENDSTR) do
      N := N+1;
    LENGTHZ := N-1
  end;

{!indexz.p!}
  { indexz -- find position of character c in stringz s }
  function INDEXZ(var S : STRINGZ;
                  C : CHARACTER) : Integer;
  var
    I : Integer;
  begin
    I := 1;
    while ((S[I] <> C) and
           (S[I] <> ENDSTR)) do
      I := I+1;
    if (S[I] = ENDSTR) then
      INDEXZ := 0
    else
      INDEXZ := I
  end;

{!xindex.p!}
  { xindex -- conditionally invert value from index }
  function XINDEX(var INSET : STRINGZ;
                  C : CHARACTER;
                  ALLBUT : Boolean;
                  LASTTO : Integer) : Integer;
  begin
    if (C = ENDFILE) then
      XINDEX := 0
    else if (not ALLBUT) then
      XINDEX := INDEXZ(INSET, C)
    else if (INDEXZ(INSET, C) > 0) then
      XINDEX := 0
    else
      XINDEX := LASTTO+1
  end;

{!translit.p!}
  { translit -- map characters }
  procedure TRANSLIT;
  const
    NEGATE = CARET;             { ^ }
  var
    ARG, FROMSET, TOSET : STRINGZ;
    C : CHARACTER;
    I, LASTTO : 0..MAXSTR;
    ALLBUT, SQUASH : Boolean;

#include "makeset.p"
#include "xindex.p"
  begin
    if (not GETARG(1, ARG, MAXSTR)) then
      ERROR('usage: translit from to');
    ALLBUT := (ARG[1] = NEGATE);
    if (ALLBUT) then
      I := 2
    else
      I := 1;
    if (not MAKESET(ARG, I, FROMSET, MAXSTR)) then
      ERROR('translit: "from" set too large');
    if (not GETARG(2, ARG, MAXSTR)) then
      TOSET[1] := ENDSTR
    else if (not MAKESET(ARG, 1, TOSET, MAXSTR)) then
      ERROR('translit: "to" set too large')
    else if (LENGTHZ(FROMSET) < LENGTHZ(TOSET)) then
      ERROR('translit: "from" shorter than "to"');

    LASTTO := LENGTHZ(TOSET);
    SQUASH := (LENGTHZ(FROMSET) > LASTTO) or (ALLBUT);
    repeat
      I := XINDEX(FROMSET, GETC(C), ALLBUT, LASTTO);
      if ((SQUASH) and
          (I >= LASTTO) and
          (LASTTO > 0)) then
        begin
          PUTC(TOSET[LASTTO]);
          repeat
            I := XINDEX(FROMSET, GETC(C), ALLBUT, LASTTO)
          until (I < LASTTO)
        end;
      if (C <> ENDFILE) then
        begin
          if ((I > 0) and
              (LASTTO > 0)) then { translate }
            PUTC(TOSET[I])
          else if (I = 0) then  { copy }
            PUTC(C)
            { else delete }
        end
    until (C = ENDFILE)
  end;

{!makeset.p!}
  { makeset -- make set from inset[k] in outset }
  function MAKESET(var INSET : STRINGZ;
                   K : Integer;
                   var OUTSET : STRINGZ;
                   MAXSET : Integer) : Boolean;
  var
    J : Integer;

#include "dodash.p"
  begin
    J := 1;
    DODASH(ENDSTR, INSET, K, OUTSET, J, MAXSET);
    MAKESET := ADDSTR(ENDSTR, OUTSET, J, MAXSET)
  end;

{!addstr.p!}
  { addstr -- put c in outset[j] if it fits, increment j }
  function ADDSTR(C : CHARACTER;
                  var OUTSET : STRINGZ;
                  var J : Integer;
                  MAXSET : Integer) : Boolean;
  begin
    if (J > MAXSET) then
      ADDSTR := False
    else
      begin
        OUTSET[J] := C;
        J := J+1;
        ADDSTR := True
      end
  end;

{!dodash.p!}
  { dodash -- expand set at src[i] into dest[j], stop at delim }
  procedure DODASH(DELIM : CHARACTER;
                   var SRC : STRINGZ;
                   var I : Integer;
                   var DEST : STRINGZ;
                   var J : Integer;
                   MAXSET : Integer);
  const
    ESCAPE = ATSIGN;
  var
    K : Integer;
    JUNK : Boolean;
  begin
    while ((SRC[I] <> DELIM) and
           (SRC[I] <> ENDSTR)) do
      begin
        if (SRC[I] = ESCAPE) then
          JUNK := ADDSTR(ESC(SRC, I), DEST, J, MAXSET)
        else if (SRC[I] <> DASH) then
          JUNK := ADDSTR(SRC[I], DEST, J, MAXSET)
        else if ((J <= 1) or
                 (SRC[I+1] = ENDSTR)) then
          JUNK := ADDSTR(DASH, DEST, J, MAXSET) { literal - }
        else if ((ISALPHANUM(SRC[I-1])) and
                 (ISALPHANUM(SRC[I+1])) and
                 (SRC[I-1] <= SRC[I+1])) then
          begin
            for K := SRC[I-1]+1 to SRC[I+1] do
              JUNK := ADDSTR(K, DEST, J, MAXSET);
            I := I+1
          end
        else
          JUNK := ADDSTR(DASH, DEST, J, MAXSET);
        I := I+1
      end
  end;

{!isalnum.p!}
  { isalphanum -- true if c is letter or digit }
  function ISALPHANUM(C : CHARACTER) : Boolean;
  begin
    ISALPHANUM := C in [Ord('a') ..Ord('z'),
                  Ord('A') ..Ord('Z'),
                  Ord('0') ..Ord('9')]
  end;

{!esc.p!}
  { esc -- map s[i] into escaped character, increment i }
  function ESC(var S : STRINGZ;
               var I : Integer) : CHARACTER;
  const
    ESCAPE = ATSIGN;            { @ }
  begin
    if (S[I] <> ESCAPE) then
      ESC := S[I]
    else if (S[I+1] = ENDSTR) then { @ not special at end }
      ESC := ESCAPE
    else
      begin
        I := I+1;
        if (S[I] = Ord('n')) then
          ESC := NEWLINE
        else if (S[I] = Ord('t')) then
          ESC := TAB
        else
          ESC := S[I]
      end
  end;

{!putdec.p!}
  { putdec -- put decimal integer n in field width >= w }
  procedure PUTDEC(N, W : Integer);
  var
    I, ND : Integer;
    S : STRINGZ;
  begin
    ND := ITOC(N, S, 1);
    for I := ND to W do
      PUTC(BLANK);
    for I := 1 to ND-1 do
      PUTC(S[I])
  end;

{!itoc.p!}
  { itoc -- convert integer n to char stringz in s[i]... }
  function ITOC(N : Integer;
                var S : STRINGZ;
                I : Integer) : Integer; { returns end of s }
  begin
    if (N < 0) then
      begin
        S[I] := Ord('-');
        ITOC := ITOC(-N, S, I+1)
      end
    else
      begin
        if (N >= 10) then
          I := ITOC(N div 10, S, I);
        S[I] := N mod 10+Ord('0');
        S[I+1] := ENDSTR;
        ITOC := I+1
      end
  end;

{!ctoi.p!}
  { ctoi -- convert stringz at s[i] to integer, increment i }
  function CTOI(var S : STRINGZ;
                var I : Integer) : Integer;
  var
    N, SIGN : Integer;
  begin
    while ((S[I] = BLANK) or
           (S[I] = TAB)) do
      I := I+1;
    if (S[I] = MINUS) then
      SIGN := -1
    else
      SIGN := 1;
    if ((S[I] = PLUS) or
        (S[I] = MINUS)) then
      I := I+1;
    N := 0;
    while (ISDIGIT(S[I])) do
      begin
        N := 10*N+S[I]-Ord('0');
        I := I+1
      end;
    CTOI := SIGN*N
  end;

{!isdigit.p!}
  { isdigit -- true if c is a digit }
  function ISDIGIT(C : CHARACTER) : Boolean;
  begin
    ISDIGIT := C in [Ord('0') ..Ord('9')]
  end;

{!equal.p!}
  { equal -- test two stringzs for equality }
  function EQUAL(var STR1, STR2 : STRINGZ) : Boolean;
  var
    I : Integer;
  begin
    I := 1;
    while ((STR1[I] = STR2[I]) and
           (STR1[I] <> ENDSTR)) do
      I := I+1;
    EQUAL := (STR1[I] = STR2[I])
  end;

{!compare1.p!}
  { compare1 -- (simple version) compare two files for equality }
  procedure COMPARE1;
  var
    LINE1, LINE2 : STRINGZ;
    LINENO : Integer;
    F1, F2 : Boolean;

#include "diffmsg.p"
  begin
    LINENO := 0;
    repeat
      LINENO := LINENO+1;
      F1 := GETLINE(LINE1, INFILE1, MAXSTR);
      F2 := GETLINE(LINE2, INFILE2, MAXSTR);
      if (F1 and F2) then
        if (not EQUAL(LINE1, LINE2)) then
          DIFFMSG(LINENO, LINE1, LINE2)
    until ((F1 = False) or
           (F2 = False));
    if (F2 and not F1) then
      WriteLn('compare: end of file on file1')
    else if (F1 and not F2) then
      WriteLn('compare: end of file on file2')
  end;

{!diffmsg.p!}
  { diffmsg -- print line numbers and differing lines }
  procedure DIFFMSG(N : Integer;
                    var LINE1, LINE2 : STRINGZ);
  begin
    PUTDEC(N, 1);
    PUTC(COLON);
    PUTC(NEWLINE);
    PUTSTR(LINE1, STDOUT);
    PUTSTR(LINE2, STDOUT)
  end;

{!compare.p!}
  { compare -- compare two files for equality }
  procedure COMPARE;
  var
    LINE1, LINE2 : STRINGZ;
    ARG1, ARG2 : STRINGZ;
    LINENO : Integer;
    INFILE1, INFILE2 : FILEDESC;
    F1, F2 : Boolean;

#include "diffmsg.p"
  begin
    if ((not GETARG(1, ARG1, MAXSTR)) or
        (not GETARG(2, ARG2, MAXSTR))) then
      ERROR('usage: compare file1 file2');
    INFILE1 := MUSTOPEN(ARG1, IOREAD);
    INFILE2 := MUSTOPEN(ARG2, IOREAD);
    LINENO := 0;
    repeat
      LINENO := LINENO+1;
      F1 := GETLINE(LINE1, INFILE1, MAXSTR);
      F2 := GETLINE(LINE2, INFILE2, MAXSTR);
      if (F1 and F2) then
        if (not EQUAL(LINE1, LINE2)) then
          DIFFMSG(LINENO, LINE1, LINE2)
    until ((F1 = False) or
           (F2 = False));
    if (F2 and not F1) then
      WriteLn('compare: end of file on file1')
    else if (F1 and not F2) then
      WriteLn('compare: end of file on file2')
  end;

{!mustopen.p!}
  { mustopen -- open file or die }
  function MUSTOPEN(var NAME : STRINGZ;
                    MODE : Integer) : FILEDESC;
  var
    FD : FILEDESC;
  begin
    FD := OPEN(NAME, MODE);
    if (FD = IOERROR) then
      begin
        PUTSTR(NAME, STDERR);
        ERROR(': can''t open file')
      end;
    MUSTOPEN := FD
  end;

{!getword.p!}
  { getword -- get word from s[i] into out }
  function GETWORD(var S : STRINGZ;
                   I : Integer;
                   var OUT : STRINGZ) : Integer;
  var
    J : Integer;
  begin
    while (S[I] in [BLANK, TAB, NEWLINE]) do
      I := I+1;
    J := 1;
    while (not(S[I] in [ENDSTR, BLANK, TAB, NEWLINE])) do
      begin
        OUT[J] := S[I];
        I := I+1;
        J := J+1
      end;
    OUT[J] := ENDSTR;
    if (S[I] = ENDSTR) then
      GETWORD := 0
    else
      GETWORD := I
  end;

{!includez.p!}
  { includez -- replace #include "file" by contents of file }
  procedure INCLUDEZ;
  var
    INCL : STRINGZ;             { value is '#include' }

#include "finclude.p"
  begin
    { setstring(incl, '#include'); }
    INCL[1] := Ord('#');
    INCL[2] := Ord('i');
    INCL[3] := Ord('n');
    INCL[4] := Ord('c');
    INCL[5] := Ord('l');
    INCL[6] := Ord('u');
    INCL[7] := Ord('d');
    INCL[8] := Ord('e');
    INCL[9] := ENDSTR;
    FINCLUDE(STDIN)
  end;

{!finclude.p!}
  { finclude -- include file desc f }
  procedure FINCLUDE(F : FILEDESC);
  var
    LINE, STRZ : STRINGZ;
    LOC, I : Integer;
    F1 : FILEDESC;

#include "getword.p"
  begin
    while (GETLINE(LINE, F, MAXSTR)) do
      begin
        LOC := GETWORD(LINE, 1, STRZ);
        if (not EQUAL(STRZ, INCL)) then
          PUTSTR(LINE, STDOUT)
        else
          begin
            LOC := GETWORD(LINE, LOC, STRZ);
            STRZ[LENGTHZ(STRZ)] := ENDSTR; { remove quotes }
            for I := 1 to LENGTHZ(STRZ) do
              STRZ[I] := STRZ[I+1];
            F1 := MUSTOPEN(STRZ, IOREAD);
            FINCLUDE(F1);
            CLOSEZ(F1)
          end
      end
  end;

{!concatz.p!}
  { concatz -- concatenate files into standard output }
  procedure CONCATZ;
  var
    I : Integer;
    JUNK : Boolean;
    FD : FILEDESC;
    S : STRINGZ;
  begin
    for I := 1 to NARGS do
      begin
        JUNK := GETARG(I, S, MAXSTR);
        FD := MUSTOPEN(S, IOREAD);
        FCOPY(FD, STDOUT);
        CLOSEZ(FD)
      end
  end;

{!fcopy.p!}
  { fcopy -- copy file fin to file fout }
  procedure FCOPY(FIN, FOUT : FILEDESC);
  var
    C : CHARACTER;
  begin
    while (GETCF(C, FIN) <> ENDFILE) do
      PUTCF(C, FOUT)
  end;

{!print1.p!}
  { print1 -- print files with headings }
  procedure PRINT1;
  var
    NAME : STRINGZ;
    I : Integer;
    FIN : FILEDESC;
    JUNK : Boolean;

#include "fprint.p"
  begin
    for I := 1 to NARGS do
      begin
        JUNK := GETARG(I, NAME, MAXSTR);
        FIN := MUSTOPEN(NAME, IOREAD);
        FPRINT(NAME, FIN);
        CLOSEZ(FIN)
      end
  end;

{!fprint.p!}
  { fprint -- print file "name" from fin }
  procedure FPRINT(var NAME : STRINGZ;
                   FIN : FILEDESC);
  const
    MARGIN1 = 2;
    MARGIN2 = 2;
    BOTTOM = 64;
    PAGELEN = 66;
  var
    LINE : STRINGZ;
    LINENO, PAGENO : Integer;

#include "skip.p"
#include "head.p"
  begin
    PAGENO := 1;
    SKIP(MARGIN1);
    HEAD(NAME, PAGENO);
    SKIP(MARGIN2);
    LINENO := MARGIN1+MARGIN2+1;
    while (GETLINE(LINE, FIN, MAXSTR)) do
      begin
        if (LINENO = 0) then
          begin
            SKIP(MARGIN1);
            PAGENO := PAGENO+1;
            HEAD(NAME, PAGENO);
            SKIP(MARGIN2);
            LINENO := MARGIN1+MARGIN2+1
          end;
        PUTSTR(LINE, STDOUT);
        LINENO := LINENO+1;
        if (LINENO >= BOTTOM) then
          begin
            SKIP(PAGELEN-LINENO);
            LINENO := 0
          end
      end;
    if (LINENO > 0) then
      SKIP(PAGELEN-LINENO)
  end;

{!skip.p!}
  { skip -- output n blank lines }
  procedure SKIP(N : Integer);
  var
    I : Integer;
  begin
    for I := 1 to N do
      PUTC(NEWLINE)
  end;

{!head.p!}
  { head -- print top of page header }
  procedure HEAD(var NAME : STRINGZ;
                 PAGENO : Integer);
  var
    PAGE : STRINGZ;             { set to ' Page ' }
  begin
    { setstring(page, ' Page '); }
    PAGE[1] := Ord(' ');
    PAGE[2] := Ord('P');
    PAGE[3] := Ord('a');
    PAGE[4] := Ord('g');
    PAGE[5] := Ord('e');
    PAGE[6] := Ord(' ');
    PAGE[7] := ENDSTR;
    PUTSTR(NAME, STDOUT);
    PUTSTR(PAGE, STDOUT);
    PUTDEC(PAGENO, 1);
    PUTC(NEWLINE)
  end;

{!print.p!}
  { print -- (default input STDIN) print files with headings }
  procedure PRINT;
  var
    NAME : STRINGZ;
    NULL : STRINGZ;             { value '' }
    I : Integer;
    FIN : FILEDESC;
    JUNK : Boolean;

#include "fprint.p"
  begin
    { setstring (null, ''); }
    NULL[1] := ENDSTR;
    if (NARGS = 0) then
      FPRINT(NULL, STDIN)
    else
      for I := 1 to NARGS do
        begin
          JUNK := GETARG(I, NAME, MAXSTR);
          FIN := MUSTOPEN(NAME, IOREAD);
          FPRINT(NAME, FIN);
          CLOSEZ(FIN)
        end
  end;

{!makecopy.p!}
  { makecopy -- copy one file to another }
  procedure MAKECOPY;
  var
    INNAME, OUTNAME : STRINGZ;
    FIN, FOUT : FILEDESC;
  begin
    if ((not GETARG(1, INNAME, MAXSTR)) or
        (not GETARG(2, OUTNAME, MAXSTR))) then
      ERROR('usage: makecopy old new');
    FIN := MUSTOPEN(INNAME, IOREAD);
    FOUT := MUSTCREATE(OUTNAME, IOWRITE);
    FCOPY(FIN, FOUT);
    CLOSEZ(FIN);
    CLOSEZ(FOUT)
  end;

{!mustcrea.p!}
  { mustcreate -- create file or die }
  function MUSTCREATE(var NAME : STRINGZ;
                      MODE : Integer) : FILEDESC;
  var
    FD : FILEDESC;
  begin
    FD := CREATE(NAME, MODE);
    if (FD = IOERROR) then
      begin
        PUTSTR(NAME, STDERR);
        ERROR(': can''t create file')
      end;
    MUSTCREATE := FD
  end;

{!help.p!}
  { help -- print diagnostic for archive }
  procedure HELP;
  begin
    ERROR('usage: archive -[cdptux] archname [files...]')
  end;

{!getfns.p!}
  { getfns -- get filenames into fname, look for duplicates }
  procedure GETFNS;
  var
    I, J : Integer;
    JUNK : Boolean;
  begin
    ERRCOUNT := 0;
    NFILES := NARGS-2;
    if (NFILES > MAXFILES) then
      ERROR('archive: too many file names');
    for I := 1 to NFILES do
      JUNK := GETARG(I+2, FNAME[I], MAXSTR);
    for I := 1 to NFILES do
      FSTAT[I] := False;
    for I := 1 to NFILES-1 do
      for J := I+1 to NFILES do
        if (EQUAL(FNAME[I], FNAME[J])) then
          begin
            PUTSTR(FNAME[I], STDERR);
            ERROR(': duplicate file name')
          end
  end;

{!update.p!}
  { update -- update existing files, add new ones at end }
  procedure UPDATE(var ANAME : STRINGZ;
                   CMD : CHARACTER);
  var
    I : Integer;
    AFD, TFD : FILEDESC;
  begin
    TFD := MUSTCREATE(ARCHTEMP, IOWRITE);
    if (CMD = Ord('u')) then
      begin
        AFD := MUSTOPEN(ANAME, IOREAD);
        REPLACE(AFD, TFD, Ord('u')); { update existing }
        CLOSEZ(AFD)
      end;
    for I := 1 to NFILES do
      if (FSTAT[I] = False) then
        begin
          ADDFILE(FNAME[I], TFD);
          FSTAT[I] := True
        end;
    CLOSEZ(TFD);
    if (ERRCOUNT = 0) then
      FMOVE(ARCHTEMP, ANAME)
    else
      WriteLn('fatal errors - archive not altered');
    REMOVE(ARCHTEMP)
  end;

{!fmove.p!}
  { fmove -- move file name1 to name2 }
  procedure FMOVE(var NAME1, NAME2 : STRINGZ);
  var
    FD1, FD2 : FILEDESC;
  begin
    FD1 := MUSTOPEN(NAME1, IOREAD);
    FD2 := MUSTCREATE(NAME2, IOWRITE);
    FCOPY(FD1, FD2);
    CLOSEZ(FD1);
    CLOSEZ(FD2);
  end;

{!addfile.p!}
  { addfile -- add file "name" to archive }
  procedure ADDFILE(var NAME : STRINGZ;
                    FD : FILEDESC);
  var
    HEAD : STRINGZ;
    NFD : FILEDESC;

#include "makehdr.p"
  begin
    NFD := OPEN(NAME, IOREAD);
    if (NFD = IOERROR) then
      begin
        PUTSTR(NAME, STDERR);
        MESSAGE(': can''t add');
        ERRCOUNT := ERRCOUNT+1
      end;
    if (ERRCOUNT = 0) then
      begin
        MAKEHDR(NAME, HEAD);
        PUTSTR(HEAD, FD);
        FCOPY(NFD, FD);
        CLOSEZ(NFD)
      end
  end;

{!makehdr.p!}
  { makehdr -- make header line for archive member }
  procedure MAKEHDR(var NAME, HEAD : STRINGZ);
  var
    I : Integer;
  begin
    SCOPY(ARCHHDR, 1, HEAD, 1);
    I := LENGTHZ(HEAD)+1;
    HEAD[I] := BLANK;
    SCOPY(NAME, 1, HEAD, I+1);
    I := LENGTHZ(HEAD)+1;
    HEAD[I] := BLANK;
    I := ITOC(FSIZE(NAME), HEAD, I+1);
    HEAD[I] := NEWLINE;
    HEAD[I+1] := ENDSTR
  end;

{!scopy.p!}
  { scopy -- copy string at src[i] to dest[j] }
  procedure SCOPY(var SRC : STRINGZ;
                  I : Integer;
                  var DEST : STRINGZ;
                  J : Integer);
  begin
    while (SRC[I] <> ENDSTR) do
      begin
        DEST[J] := SRC[I];
        I := I+1;
        J := J+1
      end;
    DEST[J] := ENDSTR;
  end;

{!fsize.p!}
  { fsize -- size of file in characters }
  function FSIZE(var NAME : STRINGZ) : Integer;
  var
    C : CHARACTER;
    FD : FILEDESC;
    N : Integer;
  begin
    N := 0;
    FD := MUSTOPEN(NAME, IOREAD);
    while (GETCF(C, FD) <> ENDFILE) do
      N := N+1;
    CLOSEZ(FD);
    FSIZE := N
  end;

{!table.p!}
  { table -- print table of archive contents }
  procedure TABLE(var ANAME : STRINGZ);
  var
    HEAD, NAME : STRINGZ;
    SIZE : Integer;
    AFD : FILEDESC;

#include "tprint.p"
  begin
    AFD := MUSTOPEN(ANAME, IOREAD);
    while (GETHDR(AFD, HEAD, NAME, SIZE)) do
      begin
        if (FILEARG(NAME)) then
          TPRINT(HEAD);
        FSKIP(AFD, SIZE)
      end;
    NOTFOUND
  end;

{!tprint.p!}
  { tprint -- print table entry for one member }
  procedure TPRINT(var BUF : STRINGZ);
  var
    I : Integer;
    TEMP : STRINGZ;
  begin
    I := GETWORD(BUF, 1, TEMP); { header }
    I := GETWORD(BUF, I, TEMP); { name }
    PUTSTR(TEMP, STDOUT);
    PUTC(BLANK);
    I := GETWORD(BUF, I, TEMP); { size }
    PUTSTR(TEMP, STDOUT);
    PUTC(NEWLINE)
  end;

{!gethdr.p!}
  { gethdr -- get header info from fd }
  function GETHDR(FD : FILEDESC;
                  var BUF, NAME : STRINGZ;
                  var SIZE : Integer) : Boolean;
  var
    TEMP : STRINGZ;
    I : Integer;
  begin
    if (GETLINE(BUF, FD, MAXSTR) = False) then
      GETHDR := False
    else
      begin
        I := GETWORD(BUF, 1, TEMP);
        if (not EQUAL(TEMP, ARCHHDR)) then
          ERROR('archive not in proper format');
        I := GETWORD(BUF, I, NAME);
        SIZE := CTOI(BUF, I);
        GETHDR := True
      end
  end;

{!fskip.p!}
  { fskip -- skip n characters on file fd }
  procedure FSKIP(FD : FILEDESC;
                  N : Integer);
  var
    C : CHARACTER;
    I : Integer;
  begin
    for I := 1 to N do
      if (GETCF(C, FD) = ENDFILE) then
        ERROR('archive: end of file in fskip')
  end;

{!filearg.p!}
  { filearg -- check if name matches argument list }
  function FILEARG(var NAME : STRINGZ) : Boolean;
  var
    I : Integer;
    FOUND : Boolean;
  begin
    if (NFILES <= 0) then
      FILEARG := True
    else
      begin
        FOUND := False;
        I := 1;
        while ((not FOUND) and
               (I <= NFILES)) do
          begin
            if (EQUAL(NAME, FNAME[I])) then
              begin
                FSTAT[I] := True;
                FOUND := True
              end;
            I := I+1
          end;
        FILEARG := FOUND
      end
  end;

{!notfound.p!}
  { notfound -- print "not found" warning }
  procedure NOTFOUND;
  var
    I : Integer;
  begin
    for I := 1 to NFILES do
      if (FSTAT[I] = False) then
        begin
          PUTSTR(FNAME[I], STDERR);
          WriteLn(': not in archive');
          ERRCOUNT := ERRCOUNT+1
        end
  end;

{!extract.p!}
  { extract -- extract files from archive }
  procedure EXTRACT(var ANAME : STRINGZ;
                    CMD : CHARACTER);
  var
    ENAME, INLINEZ : STRINGZ;
    AFD, EFD : FILEDESC;
    SIZE : Integer;
  begin
    AFD := MUSTOPEN(ANAME, IOREAD);
    if (CMD = Ord('p')) then
      EFD := STDOUT
    else                        { cmd is 'x' }
      EFD := IOERROR;
    while (GETHDR(AFD, INLINEZ, ENAME, SIZE)) do
      if (not FILEARG(ENAME)) then
        FSKIP(AFD, SIZE)
      else
        begin
          if (EFD <> STDOUT) then
            EFD := CREATE(ENAME, IOWRITE);
          if (EFD = IOERROR) then
            begin
              PUTSTR(ENAME, STDERR);
              WriteLn(': cant''t create');
              ERRCOUNT := ERRCOUNT+1;
              FSKIP(AFD, SIZE)
            end
          else
            begin
              ACOPY(AFD, EFD, SIZE);
              if (EFD <> STDOUT) then
                CLOSEZ(EFD)
            end
        end;
    NOTFOUND
  end;

{!acopy.p!}
  { acopy -- copy n characters from fdi to fdo }
  procedure ACOPY(FDI, FDO : FILEDESC;
                  N : Integer);
  var
    C : CHARACTER;
    I : Integer;
  begin
    for I := 1 to N do
      if (GETCF(C, FDI) = ENDFILE) then
        ERROR('archive: end of file in acopy')
      else
        PUTCF(C, FDO)
  end;

{!deletez.p!}
  { deletez -- delete files from archive }
  procedure DELETEZ(var ANAME : STRINGZ);
  var
    AFD, TFD : FILEDESC;
  begin
    if (NFILES <= 0) then       { protect innocents }
      ERROR('archive: -d requires explicit file names');
    AFD := MUSTOPEN(ANAME, IOREAD);
    TFD := MUSTCREATE(ARCHTEMP, IOWRITE);
    REPLACE(AFD, TFD, Ord('d'));
    NOTFOUND;
    CLOSEZ(AFD);
    CLOSEZ(TFD);
    if (ERRCOUNT = 0) then
      FMOVE(ARCHTEMP, ANAME)
    else
      WriteLn('fatal errors - archive not altered');
    REMOVE(ARCHTEMP)
  end;

{!replace.p!}
  { replace -- replace or delete files }
  procedure REPLACE(AFD, TFD : FILEDESC;
                    CMD : Integer);
  var
    INLINEZ, UNAME : STRINGZ;
    SIZE : Integer;
  begin
    while (GETHDR(AFD, INLINEZ, UNAME, SIZE)) do
      if (FILEARG(UNAME)) then
        begin
          if (CMD = Ord('u')) then { add new one }
            ADDFILE(UNAME, TFD);
          FSKIP(AFD, SIZE)      { discard old one }
        end
      else
        begin
          PUTSTR(INLINEZ, TFD);
          ACOPY(AFD, TFD, SIZE)
        end
  end;

{!archive.p!}
  { archive -- file maintainer }
  procedure Archive;
  const
    MAXFILES = 100;             { or whatever }
  var
    ANAME : STRINGZ;            { archive name }
    CMD : STRINGZ;              { command type }
    FNAME : array[1..MAXFILES] of STRINGZ; { filename args }
    FSTAT : array[1..MAXFILES] of Boolean; { true=in archive }
    NFILES : Integer;           { number of filename arguments }
    ERRCOUNT : Integer;         { number of errors }
    ARCHTEMP : STRINGZ;         { temp file name 'artemp' }
    ARCHHDR : STRINGZ;          { header string '-h-' }

#include "archproc.p"
  begin
    INITARCH;
    if ((not GETARG(1, CMD, MAXSTR)) or
        (not GETARG(2, ANAME, MAXSTR))) then
      HELP;
    GETFNS;
    if ((LENGTHZ(CMD) <> 2) or
        (CMD[1] <> Ord('-'))) then
      HELP
    else if ((CMD[2] = Ord('c')) or
             (CMD[2] = Ord('u'))) then
      UPDATE(ANAME, CMD[2])
    else if (CMD[2] = Ord('t')) then
      TABLE(ANAME)
    else if ((CMD[2] = Ord('x')) or
             (CMD[2] = Ord('p'))) then
      EXTRACT(ANAME, CMD[2])
    else if (CMD[2] = Ord('d')) then
      DELETEZ(ANAME)
    else
      HELP
  end;

{!initarch.p!}
  { initarch -- initialize variables for archive }
  procedure INITARCH;
  begin
    { setstring (archtemp, 'artemp'); }
    ARCHTEMP[1] := Ord('a');
    ARCHTEMP[2] := Ord('r');
    ARCHTEMP[3] := Ord('t');
    ARCHTEMP[4] := Ord('e');
    ARCHTEMP[5] := Ord('m');
    ARCHTEMP[6] := Ord('p');
    ARCHTEMP[7] := ENDSTR;
    { setstring(archhdr, '-h-'); }
    ARCHHDR[1] := Ord('-');
    ARCHHDR[2] := Ord('h');
    ARCHHDR[3] := Ord('-');
    ARCHHDR[4] := ENDSTR;
  end;

{!archproc.p!}
#include "getword.p"
#include "gethdr.p"
#include "filearg.p"
#include "fskip.p"
#include "fmove.p"
#include "fsize.p"
#include "acopy.p"
#include "notfound.p"
#include "addfile.p"
#include "replace.p"
#include "help.p"
#include "getfns.p"
#include "update.p"
#include "table.p"
#include "extract.p"
#include "deletez.p"
#include "initarch.p"

{!bubble.p!}
  { bubble -- bubble sort v[1] ... v[n] increasing }
  procedure BUBBLE(var V : INTARRAY;
                   N : Integer);
  var
    I, J, K : Integer;
  begin
    for I := N downto 2 do
      for J := 1 to I-1 do
        if (V[J] > V[J+1]) then { compare}
          begin
            K := V[J];          { exchange }
            V[J] := V[J+1];
            V[J+1] := K
          end
  end;

{!shell1.p!}
  { shell -- Shell sort v[1]...v[n] increasing }
  procedure SHELL(var V : INTARRAY;
                  N : Integer);
  var
    GAP, I, J, JG, K : Integer;
  begin
    GAP := N div 2;
    while (GAP > 0) do
      begin
        for I := GAP+1 to N do
          begin
            J := I-GAP;
            while (J > 0) do
              begin
                JG := J+GAP;
                if (V[J] <= V[JG]) then { compare }
                  J := 0        { force loop termination }
                else
                  begin
                    K := V[J];  { exchange }
                    V[J] := V[JG];
                    V[JG] := K
                  end;
                J := J-GAP
              end
          end;
        GAP := GAP div 2
      end
  end;

{!sort1.p!}
  { sort -- external sort of text lines }
  procedure INMEMSORT;
  const
    MAXCHARS = 10000;           { maximum # of text characters }
    MAXLINES = 300;             { maximum # of lines }
  type
    CHARBUF = array[1..MAXCHARS] of CHARACTER;
    CHARPOS = 1..MAXCHARS;
    POSBUF = array[1..MAXLINES] of CHARPOS;
    POSZ = 0..MAXLINES;
  var
    LINEBUF : CHARBUF;
    LINEPOS : POSBUF;
    NLINES : POSZ;

#include "gtext.p"
#include "shell.p"
#include "ptext.p"
  begin
    if (GTEXT(LINEPOS, NLINES, LINEBUF, STDIN)) then
      begin
        SHELL(LINEPOS, NLINES, LINEBUF);
        PTEXT(LINEPOS, NLINES, LINEBUF, STDOUT)
      end
    else
      ERROR('sort: input too big to sort')
  end;

{!gtext.p!}
  { gtext -- get text lines into linebuf }
  function GTEXT(var LINEPOS : POSBUF;
                 var NLINES : POSZ;
                 var LINEBUF : CHARBUF;
                 INFILE : FILEDESC) : Boolean;
  var
    I, LEN, NEXTPOS : Integer;
    TEMP : STRINGZ;
    DONE : Boolean;
  begin
    NLINES := 0;
    NEXTPOS := 1;
    repeat
      DONE := (GETLINE(TEMP, INFILE, MAXSTR) = False);
      if (not DONE) then
        begin
          NLINES := NLINES+1;
          LINEPOS[NLINES] := NEXTPOS;
          LEN := LENGTHZ(TEMP);
          for I := 1 to LEN do
            LINEBUF[NEXTPOS+I-1] := TEMP[I];
          LINEBUF[NEXTPOS+LEN] := ENDSTR;
          NEXTPOS := NEXTPOS+LEN+1 { 1 for ENDSTR }
        end
    until ((DONE) or
           (NEXTPOS >= MAXCHARS-MAXSTR) or
           (NLINES >= MAXLINES));
    GTEXT := DONE
  end;

{!ptext.p!}
  { ptext -- output text lines from linebuf }
  procedure PTEXT(var LINEPOS : POSBUF;
                  NLINES : Integer;
                  var LINEBUF : CHARBUF;
                  OUTFILE : FILEDESC);
  var
    I, J : Integer;
  begin
    for I := 1 to NLINES do
      begin
        J := LINEPOS[I];
        while (LINEBUF[J] <> ENDSTR) do
          begin
            PUTCF(LINEBUF[J], OUTFILE);
            J := J+1
          end
      end
  end;

{!shell.p!}
  { shell -- ascending Shell sort for lines }
  procedure SHELL(var LINEPOS : POSBUF;
                  NLINES : Integer;
                  var LINEBUF : CHARBUF);
  var
    GAP, I, J, JG : Integer;

#include "cmp.p"
#include "exchange.p"
  begin
    GAP := NLINES div 2;
    while (GAP > 0) do
      begin
        for I := GAP+1 to NLINES do
          begin
            J := I-GAP;
            while (J > 0) do
              begin
                JG := J+GAP;
                if (CMP(LINEPOS[J], LINEPOS[JG], LINEBUF) <= 0) then
                  J := 0        { force loop termination }
                else
                  begin
                    EXCHANGE(LINEPOS[J], LINEPOS[JG]);
                  end;
                J := J-GAP
              end
          end;
        GAP := GAP div 2
      end
  end;

{!exchange.p!}
  { exchange -- exchange linebuf[lp1] with linebuf[lp2] }
  procedure EXCHANGE(var LP1, LP2 : CHARPOS);
  var
    TEMP : CHARPOS;
  begin
    TEMP := LP1;
    LP1 := LP2;
    LP2 := TEMP
  end;

{!cmp.p!}
  { cmp -- compare linebuf[i] with linebuf[j] }
  function CMP(I, J : CHARPOS;
               var LINEBUF : CHARBUF) : Integer;
  begin
    while ((LINEBUF[I] = LINEBUF[J]) and
           (LINEBUF[I] <> ENDSTR)) do
      begin
        I := I+1;
        J := J+1
      end;
    if (LINEBUF[I] = LINEBUF[J]) then
      CMP := 0
    else if (LINEBUF[I] = ENDSTR) then { 1st is shorter }
      CMP := -1
    else if (LINEBUF[J] = ENDSTR) then { 2nd is shorter }
      CMP := +1
    else if (LINEBUF[I] < LINEBUF[J]) then
      CMP := -1
    else
      CMP := +1
  end;

{!quick.p!}
  { quick -- quicksort for lines }
  procedure QUICK(var LINEPOS : POSBUF;
                  NLINE : POSZ;
                  var LINEBUF : CHARBUF);

#include "rquick.p"
  begin
    RQUICK(1, NLINES)
  end;

{!rquick.p!}
  { rquick -- recursive quicksort }
  { See Plauger's column in Computer Language, March 1987, page 16, }
  { and follow-up letters in May 1987, pages 9 & 11, for improvements. }
  procedure RQUICK(LOZ, HIZ : Integer);
  var
    I, J : Integer;
    PIVLINE : CHARPOS;
  begin
    if (LOZ < HIZ) then
      begin
        I := LOZ;
        J := HIZ;
        PIVLINE := LINEPOS[J];  { pivot line }
        repeat
          while (I < J)
          and (CMP(LINEPOS[I], PIVLINE, LINEBUF) <= 0) do
            I := I+1;
          while (J > I)
          and (CMP(LINEPOS[J], PIVLINE, LINEBUF) >= 0) do
            J := J-1;
          if (I < J) then       { out of order pair }
            EXCHANGE(LINEPOS[I], LINEPOS[J])
        until (I >= J);
        EXCHANGE(LINEPOS[I], LINEPOS[HIZ]); { move pivot to i }
        if (I-LOZ < HIZ-I) then
          begin
            RQUICK(LOZ, I-1);
            RQUICK(I+1, HIZ)
          end
        else
          begin
            RQUICK(I+1, HIZ);
            RQUICK(LOZ, I-1)
          end
      end
  end;

{!sort.p!}
  { sort -- external sort of text lines }
  procedure SORT;
  const
    MAXCHARS = 10000;           { maximum # of text characters }
    MAXLINES = 300;             { maximum # of lines }
    MERGEORDER = 5;
  type
    CHARPOS = 1..MAXCHARS;
    CHARBUF = array[1..MAXCHARS] of CHARACTER;
    POSBUF = array[1..MAXLINES] of CHARPOS;
    POSZ = 0..MAXLINES;
    FDBUF = array[1..MERGEORDER] of FILEDESC;
  var
    LINEBUF : CHARBUF;
    LINEPOS : POSBUF;
    NLINES : POSZ;
    INFILE : FDBUF;
    OUTFILE : FILEDESC;
    HIGHZ, LOWZ, LIM : Integer;
    DONE : Boolean;
    NAME : STRINGZ;

#include "sortproc.p"
  begin
    HIGHZ := 0;
    repeat                      { initial formation of runs }
      DONE := GTEXT(LINEPOS, NLINES, LINEBUF, STDIN);
      QUICK(LINEPOS, NLINES, LINEBUF);
      HIGHZ := HIGHZ+1;
      OUTFILE := MAKEFILE(HIGHZ);
      PTEXT(LINEPOS, NLINES, LINEBUF, OUTFILE);
      CLOSEZ(OUTFILE)
    until (DONE);
    LOWZ := 1;
    while (LOWZ < HIGHZ) do
      begin                     { merge runs }
        LIM := MIN(LOWZ+MERGEORDER-1, HIGHZ);
        GOPEN(INFILE, LOWZ, LIM);
        HIGHZ := HIGHZ+1;
        OUTFILE := MAKEFILE(HIGHZ);
        MERGE(INFILE, LIM-LOWZ+1, OUTFILE);
        CLOSEZ(OUTFILE);
        GREMOVE(INFILE, LOWZ, LIM);
        LOWZ := LOWZ+MERGEORDER
      end;
    GNAME(HIGHZ, NAME);         { final cleanup }
    OUTFILE := OPEN(NAME, IOREAD);
    FCOPY(OUTFILE, STDOUT);
    CLOSEZ(OUTFILE);
    REMOVE(NAME)
  end;


{!sortproc.p!}
  { sortproc -- procedures for sort }

#include "cmp.p"
#include "exchange.p"
#include "gtext.p"
#include "ptext.p"
#include "quick.p"
#include "gname.p"
#include "makefile.p"
#include "gopen.p"
#include "merge.p"
#include "gremove.p"

{!makefile.p!}
  { makefile -- make new file for number n }
  function MAKEFILE(N : Integer) : FILEDESC;
  var
    NAME : STRINGZ;
  begin
    GNAME(N, NAME);
    MAKEFILE := MUSTCREATE(NAME, IOWRITE)
  end;

{!gname.p!}
  { gname -- generate unique name for file id n }
  procedure GNAME(N : Integer;
                  var NAME : STRINGZ);
  var
    JUNK : Integer;
  begin
    { setstring(name, 'stemp'); }
    NAME[1] := Ord('s');
    NAME[2] := Ord('t');
    NAME[3] := Ord('e');
    NAME[4] := Ord('m');
    NAME[5] := Ord('p');
    NAME[6] := ENDSTR;
    JUNK := ITOC(N, NAME, LENGTHZ(NAME)+1)
  end;

{!gopen.p!}
  { gopen -- open group of files f1 ... f2 }
  procedure GOPEN(var INFILE : FDBUF;
                  F1, F2 : Integer);
  var
    NAME : STRINGZ;
    I : 1..MERGEORDER;
  begin
    for I := 1 to F2-F1+1 do
      begin
        GNAME(F1+I-1, NAME);
        INFILE[I] := MUSTOPEN(NAME, IOREAD)
      end
  end;

{!gremove.p!}
  { gremove -- remove group of files f1 ... f2 }
  procedure GREMOVE(var INFILE : FDBUF;
                    F1, F2 : Integer);
  var
    NAME : STRINGZ;
    I : 1..MERGEORDER;
  begin
    for I := 1 to F2-F1+1 do
      begin
        CLOSEZ(INFILE[I]);
        GNAME(F1+I-1, NAME);
        REMOVE(NAME)
      end
  end;

{!merge.p!}
  { merge -- merge infile[1] ... infile [nf] onto outfile }
  procedure MERGE(var INFILE : FDBUF;
                  NF : Integer;
                  OUTFILE : FILEDESC);
  var
    I, J : Integer;
    LBP : CHARPOS;
    TEMP : STRINGZ;

#include "reheap.p"
#include "sccopy.p"
#include "cscopy.p"
  begin
    J := 0;
    for I := 1 to NF do
      if (GETLINE(TEMP, INFILE[I], MAXSTR)) then
        begin
          LBP := (I-1)*MAXSTR+1; { room for longest }
          SCCOPY(TEMP, LINEBUF, LBP);
          LINEPOS[I] := LBP;
          J := J+1
        end;
    NF := J;
    QUICK(LINEPOS, NF, LINEBUF); { make initial heap }
    while (NF > 0) do
      begin
        LBP := LINEPOS[1];      { lowest line }
        CSCOPY(LINEBUF, LBP, TEMP);
        PUTSTR(TEMP, OUTFILE);
        I := LBP div MAXSTR+1;  { compute file index }
        if (GETLINE(TEMP, INFILE[I], MAXSTR)) then
          SCCOPY(TEMP, LINEBUF, LBP)
        else
          begin                 { one less input file }
            LINEPOS[1] := LINEPOS[NF];
            NF := NF-1
          end;
        REHEAP(LINEPOS, NF, LINEBUF)
      end
  end;

{!sccopy.p!}
  { sccopy -- copy string s into cb[i]... }
  procedure SCCOPY(var S : STRINGZ;
                   var CB : CHARBUF;
                   I : CHARPOS);
  var
    J : Integer;
  begin
    J := 1;
    while (S[J] <> ENDSTR) do
      begin
        CB[I] := S[J];
        J := J+1;
        I := I+1
      end;
    CB[I] := ENDSTR
  end;

{!cscopy.p!}
  { cscopy -- copy cs[i]... to string s }
  procedure CSCOPY(var CB : CHARBUF;
                   I : CHARPOS;
                   var S : STRINGZ);
  var
    J : Integer;
  begin
    J := 1;
    while (CB[I] <> ENDSTR) do
      begin
        S[J] := CB[I];
        I := I+1;
        J := J+1
      end;
    S[J] := ENDSTR
  end;

{!reheap.p!}
  { reheap -- put linebuf[linepos[i]] in proper place in heap }
  procedure REHEAP(var LINEPOS : POSBUF;
                   NF : POSZ;
                   var LINEBUF : CHARBUF);
  var
    I, J : Integer;
  begin
    I := 1;
    J := 2*I;
    while (J <= NF) do
      begin
        if (J < NF) then        { find smaller child }
          if (CMP(LINEPOS[J], LINEPOS[J+1], LINEBUF) > 0) then
            J := J+1;
        if (CMP(LINEPOS[I], LINEPOS[J], LINEBUF) <= 0) then
          I := NF               { proper position found; terminate loop }
        else
          EXCHANGE(LINEPOS[I], LINEPOS[J]); { percolate }
        I := J;
        J := 2*I
      end
  end;

{!unique.p!}
  { unique -- remove adjacent duplicate lines }
  procedure UNIQUE;
  var
    BUF : array[0..1] of STRINGZ;
    CUR : 0..1;
  begin
    CUR := 1;
    BUF[1-CUR][1] := ENDSTR;
    while (GETLINE(BUF[CUR], STDIN, MAXSTR)) do
      if (not EQUAL(BUF[CUR], BUF[1-CUR])) then
        begin
          PUTSTR(BUF[CUR], STDOUT);
          CUR := 1-CUR
        end
  end;

{!kwic.p!}
  { kwic -- make keyword in context index }
  procedure KWIC;
  const
    FOLD = DOLLAR;
  var
    BUF : STRINGZ;

#include "putrot.p"
  begin
    while (GETLINE(BUF, STDIN, MAXSTR)) do
      PUTROT(BUF)
  end;

{!putrot.p!}
  { putrot -- create lines with keyword at front }
  procedure PUTROT(var BUF : STRINGZ);
  var
    I : Integer;

#include "rotate.p"
  begin
    I := 1;
    while ((BUF[I] <> NEWLINE) and
           (BUF[I] <> ENDSTR)) do
      begin
        if (ISALPHANUM(BUF[I])) then
          begin
            ROTATE(BUF, I);     { token starts at "i" }
            repeat
              I := I+1
            until (not ISALPHANUM(BUF[I]))
          end;
        I := I+1
      end
  end;

{!rotate.p!}
  { rotate -- output rotated line }
  procedure ROTATE(var BUF : STRINGZ;
                   N : Integer);
  var
    I : Integer;
  begin
    I := N;
    while ((BUF[I] <> NEWLINE) and
           (BUF[I] <> ENDSTR)) do
      begin
        PUTC(BUF[I]);
        I := I+1
      end;
    PUTC(FOLD);
    for I := 1 to N-1 do
      PUTC(BUF[I]);
    PUTC(NEWLINE)
  end;

{!unrotate.p!}
  { unrotate -- unrotate lines rotated by kwic }
  procedure UNROTATE;
  const
    MAXOUT = 80;
    MIDDLE = 40;
    FOLD = DOLLAR;
  var
    INBUF, OUTBUF : STRINGZ;
    I, J, F : Integer;
  begin
    while (GETLINE(INBUF, STDIN, MAXSTR)) do
      begin
        for I := 1 to MAXOUT-1 do
          OUTBUF[I] := BLANK;
        F := INDEXZ(INBUF, FOLD);
        J := MIDDLE-1;
        for I := LENGTHZ(INBUF)-1 downto F+1 do
          begin
            OUTBUF[J] := INBUF[I];
            J := J-1;
            if (J <= 0) then
              J := MAXOUT-1
          end;
        J := MIDDLE+1;
        for I := 1 to F-1 do
          begin
            OUTBUF[J] := INBUF[I];
            J := J mod (MAXOUT-1)+1
          end;
        for J := 1 to MAXOUT-1 do
          if (OUTBUF[J] <> BLANK) then
            I := J;
        OUTBUF[I+1] := ENDSTR;
        PUTSTR(OUTBUF, STDOUT);
        PUTC(NEWLINE)
      end
  end;

{!find.p!}
  { find -- find patterns in text }
  procedure FIND;

#include "findcons.p"
  var
    ARG, LIN, PAT : STRINGZ;

#include "getpat.p"
#include "match.p"
  begin
    if (not GETARG(1, ARG, MAXSTR)) then
      ERROR('usage: find pattern');
    if (not GETPAT(ARG, PAT)) then
      ERROR('find: illegal pattern');
    while (GETLINE(LIN, STDIN, MAXSTR)) do
      if (MATCH(LIN, PAT)) then
        PUTSTR(LIN, STDOUT)
  end;

{!match.p!}
  { match -- find match anywhere on line }
  function MATCH(var LINE, PAT : STRINGZ) : Boolean;
  var
    I, POSZ : Integer;

#include "amatch.p"
  begin
    POSZ := 0;
    I := 1;
    while ((LIN[I] <> ENDSTR) and
           (POSZ = 0)) do
      begin
        POSZ := AMATCH(LIN, I, PAT, 1);
        I := I+1
      end;
    MATCH := (POSZ > 0)
  end;

{!amatch1.p!}
  { amatch -- with no metacharacters }
  function AMATCH(var LIN : STRINGZ;
                  I : Integer;
                  var PAT : STRINGZ;
                  J : Integer) : Integer;
  begin
    while (PAT[J] <> ENDSTR) do
      if (LIN[I] <> PAT[J]) then
        I := 0                  { no match }
      else
        begin
          I := I+1;
          J := J+1
        end;
    AMATCH := I
  end;

{!amatch2.p!}
  { amatch -- with some metacharacters }
  function AMATCH(var LIN : STRINGZ;
                  I : Integer;
                  var PAT : STRINGZ;
                  J : Integer) : Integer;

#include "omatch.p"
  begin
    while ((PAT[J] <> ENDSTR) and
           (I > 0)) do
      if (OMATCH(LIN, I, PAT, J)) then
        J := J+PATSIZE(PAT, J)
      else
        I := 0;                 { no match possible }
    AMATCH := I
  end;

{!amatch.p!}
  { amatch -- look for match of pat[j]... at lin[offset]... }
  function AMATCH(var LIN : STRINGZ;
                  OFFSET : Integer;
                  var PAT : STRINGZ;
                  J : Integer) : Integer;
  var
    I, K : Integer;
    DONE : Boolean;

#include "omatch.p"
#include "patsize.p"
  begin
    DONE := False;
    while ((not DONE) and
           (PAT[J] <> ENDSTR)) do
      if (PAT[J] = CLOSURE) then
        begin
          J := J+PATSIZE(PAT, J); { step over CLOSURE }
          I := OFFSET;
          { match as many as possible }
          while ((not DONE) and
                 (LIN[I] <> ENDSTR)) do
            if (not OMATCH(LIN, I, PAT, J)) then
              DONE := True;
          { i points to input character that made us fail }
          { match rest of pattern against rest of input }
          { shrink closure by 1 after each failure }
          DONE := False;
          while ((not DONE) and
                 (I >= OFFSET)) do
            begin
              K := AMATCH(LIN, I, PAT, J+PATSIZE(PAT, J));
              if (K > 0) then   { matched rest of pattern }
                DONE := True
              else
                I := I-1
            end;
          OFFSET := K;          { if k = 0 failure else success }
          DONE := True
        end
      else if (not OMATCH(LIN, OFFSET, PAT, J)) then
        begin
          OFFSET := 0;          { non-closure }
          DONE := True
        end
      else                      { omatch succeeded on this pattern element }
        J := J+PATSIZE(PAT, J);
    AMATCH := OFFSET
  end;

{!patsize.p!}
  { patsize -- returns size of pattern entry at pat[n] }
  function PATSIZE(var PAT : STRINGZ;
                   N : Integer) : Integer;
  begin
    if (not(PAT[N] in [LITCHAR, BOL, EOL, ANY, CCL, NCCL, CLOSURE])) then
      ERROR('in patsize: can''t happen')
    else
      case PAT[N] of
        LITCHAR :
          PATSIZE := 2;
        BOL, EOL, ANY :
          PATSIZE := 1;
        CCL, NCCL :
          PATSIZE := PAT[N+1]+2;
        CLOSURE :
          PATSIZE := CLOSIZE
      end
  end;

{!omatch.p!}
  { omatch -- match one pattern element at pat[j] }
  function OMATCH(var LIN : STRINGZ;
                  var I : Integer;
                  var PAT : STRINGZ;
                  J : Integer) : Boolean;
  var
    ADVANCE : -1..1;

#include "locate.p"
  begin
    ADVANCE := -1;
    if (LIN[I] = ENDSTR) then
      OMATCH := False
    else if (not(PAT[J] in [LITCHAR, BOL, EOL, ANY, CCL, NCCL, CLOSURE])) then
      ERROR('in omatch: can''t happen')
    else
      case PAT[J] of
        LITCHAR :
          if (LIN[I] = PAT[J+1]) then
            ADVANCE := 1;
        BOL :
          if (I = 1) then
            ADVANCE := 0;
        ANY :
          if (LIN[I] <> NEWLINE) then
            ADVANCE := 1;
        EOL :
          if (LIN[I] = NEWLINE) then
            ADVANCE := 0;
        CCL :
          if (LOCATE(LIN[I], PAT, J+1)) then
            ADVANCE := 1;
        NCCL :
          if ((LIN[I] <> NEWLINE) and
              (not LOCATE(LIN[I], PAT, J+1))) then
            ADVANCE := 1
      end;
    if (ADVANCE >= 0) then
      begin
        I := I+ADVANCE;
        OMATCH := True
      end
    else
      OMATCH := False
  end;

{!locate.p!}
  { locate -- look for c in character class at pat[offset] }
  function LOCATE(C : CHARACTER;
                  var PAT : STRINGZ;
                  OFFSET : Integer) : Boolean;
  var
    I : Integer;
  begin
    { size of class is at pat[offset], characters follow }
    LOCATE := False;
    I := OFFSET+PAT[OFFSET];    { last position }
    while (I > OFFSET) do
      if (C = PAT[I]) then
        begin
          LOCATE := True;
          I := OFFSET           { force loop termination }
        end
      else
        I := I-1
  end;

{!patsize1.p!}
  { patsize -- returns size of pattern entry at pat[n] }
  function PATSIZE(var PAT : STRINGZ;
                   N : Integer) : Integer;
  begin
    if (PAT[N] = LITCHAR) then
      PATSIZE := 2
    else if (PAT[N] in [BOL, EOL, ANY]) then
      PATSIZE := 1
    else if ((PAT[N] = CCL) or
             (PAT[N] = NCCL)) then
      PATSIZE := PAT[N+1]+2
    else if (PAT[N] = CLOSURE) then
      PATSIZE := CLOSIZE
    else
      ERROR('in patsize: can''t happen')
  end;

{!getpat.p!}
  { getpat -- convert arguments into pattern }
  function GETPAT(var ARG, PAT : STRINGZ) : Boolean;

#include "makepat.p"
  begin
    GETPAT := (MAKEPAT(ARG, 1, ENDSTR, PAT) > 0)
  end;

{!makepat.p!}
  { makepat -- make pattern from arg[i], terminate at delims }
  function MAKEPAT(var ARG : STRINGZ;
                   START : Integer;
                   DELIM : CHARACTER;
                   var PAT : STRINGZ) : Integer;
  var
    I, J, LASTJ, LJ : Integer;
    DONE, JUNK : Boolean;

#include "getccl.p"
#include "stclose.p"
  begin
    J := 1;                     { pat index }
    I := START;                 { arg index }
    LASTJ := 1;
    DONE := False;
    while ((not DONE) and
           (ARG[I] <> DELIM) and
           (ARG[I] <> ENDSTR)) do
      begin
        LJ := J;
        if (ARG[I] = ANY) then
          JUNK := ADDSTR(ANY, PAT, J, MAXPAT)
        else if ((ARG[I] = BOL) and
                 (I = START)) then
          JUNK := ADDSTR(BOL, PAT, J, MAXPAT)
        else if ((ARG[I] = EOL) and
                 (ARG[I+1] = DELIM)) then
          JUNK := ADDSTR(EOL, PAT, J, MAXPAT)
        else if (ARG[I] = CCL) then
          DONE := (GETCCL(ARG, I, PAT, J) = False)
        else if ((ARG[I] = CLOSURE) and
                 (I > START)) then
          begin
            LJ := LASTJ;
            if (PAT[LJ] in [BOL, EOL, CLOSURE]) then
              DONE := True      { force loop termination }
            else
              STCLOSE(PAT, J, LASTJ)
          end
        else
          begin
            JUNK := ADDSTR(LITCHAR, PAT, J, MAXPAT);
            JUNK := ADDSTR(ESC(ARG, I), PAT, J, MAXPAT)
          end;
        LASTJ := LJ;
        if (not DONE) then
          I := I+1
      end;
    if ((DONE) or
        (ARG[I] <> DELIM)) then { finished early }
      MAKEPAT := 0
    else if (not ADDSTR(ENDSTR, PAT, J, MAXPAT)) then
      MAKEPAT := 0              { no room }
    else
      MAKEPAT := I              { all is well }
  end;

{!getccl.p!}
  { getccl -- expand char class at arg[i] into pat[j] }
  function GETCCL(var ARG : STRINGZ;
                  var I : Integer;
                  var PAT : STRINGZ;
                  var J : Integer) : Boolean;
  var
    JSTART : Integer;
    JUNK : Boolean;

#include "dodash.p"
  begin
    I := I+1;                   { slip over '[' }
    if (ARG[I] = NEGATE) then
      begin
        JUNK := ADDSTR(NCCL, PAT, J, MAXPAT);
        I := I+1
      end
    else
      JUNK := ADDSTR(CCL, PAT, J, MAXPAT);
    JSTART := J;
    JUNK := ADDSTR(0, PAT, J, MAXPAT); { room for count }
    DODASH(CCLEND, ARG, I, PAT, J, MAXPAT);
    PAT[JSTART] := J-JSTART-1;
    GETCCL := (ARG[I] = CCLEND)
  end;

{!stclose.p!}
  { stclose -- insert closure entry at pat[j] }
  procedure STCLOSE(var PAT : STRINGZ;
                    var J : Integer;
                    LASTJ : Integer);
  var
    JP, JT : Integer;
    JUNK : Boolean;
  begin
    for JP := J-1 downto LASTJ do
      begin
        JT := JP+CLOSIZE;
        JUNK := ADDSTR(PAT[JP], PAT, JT, MAXPAT)
      end;
    J := J+CLOSIZE;
    PAT[LASTJ] := CLOSURE       { where original pattern began }
  end;

{!findcons.p!}
  { findcons -- const declarations for find }
const
  MAXPAT = MAXSTR;
  CLOSIZE = 1;                  { size of a closure entry }
  CLOSURE = STAR;
  BOL = PERCENT;
  EOL = DOLLAR;
  ANY = QUESTION;
  CCL = LBRACK;
  CCLEND = RBRACK;
  NEGATE = CARET;
  NCCL = EXCLAM;                { cannot be the same as NEGATE }
  LITCHAR = Ord('c');

{!change.p!}
  { change -- change "from" into "to" on each line }
  procedure CHANGE;

#include "findcons.p"
    DITTO = 255;                {TP7}
  var
    LIN, PAT, SUB, ARG : STRINGZ;

#include "getpat.p"
#include "getsub.p"
#include "subline.p"
  begin
    if (not GETARG(1, ARG, MAXSTR)) then
      ERROR('usage: change from [to]');
    if (not GETPAT(ARG, PAT)) then
      ERROR('change: illegal "from" pattern');
    if (not GETARG(2, ARG, MAXSTR)) then
      ARG[1] := ENDSTR;
    if (not GETSUB(ARG, SUB)) then
      ERROR('change: illegal "to" string');
    while (GETLINE(LIN, STDIN, MAXSTR)) do
      SUBLINE(LIN, PAT, SUB)
  end;

{!subline.p!}
  { subline -- substitute sub for pat in lin and print }
  procedure SUBLINE(var LIN, PAT, SUB : STRINGZ);
  var
    I, LASTM, M : Integer;
    JUNK : Boolean;

#include "amatch.p"
#include "putsub.p"
  begin
    LASTM := 0;
    I := 1;
    while (LIN[I] <> ENDSTR) do
      begin
        M := AMATCH(LIN, I, PAT, 1);
        if ((M > 0) and
            (LASTM <> M)) then
          begin
            { replace matched text }
            PUTSUB(LIN, I, M, SUB);
            LASTM := M
          end;
        if ((M = 0) or
            (M = I)) then
          begin
            { no match or null match }
            PUTC(LIN[I]);
            I := I+1
          end
        else                    { skip matched text }
          I := M
      end
  end;

{!getsub.p!}
  { getsub -- get substitution string into sub }
  function GETSUB(var ARG, SUB : STRINGZ) : Boolean;

#include "makesub.p"
  begin
    GETSUB := (MAKESUB(ARG, 1, ENDSTR, SUB) > 0)
  end;

{!makesub.p!}
  { makesub -- make substitution string from arg in sub }
  function MAKESUB(var ARG : STRINGZ;
                   FROM : Integer;
                   DELIM : CHARACTER;
                   var SUB : STRINGZ) : Integer;
  var
    I, J : Integer;
    JUNK : Boolean;
  begin
    J := 1;
    I := FROM;
    while ((ARG[I] <> DELIM) and
           (ARG[I] <> ENDSTR)) do
      begin
        if (ARG[I] = Ord('&')) then
          JUNK := ADDSTR(DITTO, SUB, J, MAXPAT)
        else
          JUNK := ADDSTR(ESC(ARG, I), SUB, J, MAXPAT);
        I := I+1
      end;
    if (ARG[I] <> DELIM) then   { missing delimiter }
      MAKESUB := 0
    else if (not ADDSTR(ENDSTR, SUB, J, MAXPAT)) then
      MAKESUB := 0
    else
      MAKESUB := I
  end;

{!putsub.p!}
  { putsub -- output substitution text }
  procedure PUTSUB(var LIN : STRINGZ;
                   S1, S2 : Integer;
                   var SUB : STRINGZ);
  var
    I, J : Integer;
    JUNK : Boolean;
  begin
    I := 1;
    while (SUB[I] <> ENDSTR) do
      begin
        if (SUB[I] = DITTO) then
          for J := S1 to S2-1 do
            PUTC(LIN[J])
        else
          PUTC(SUB[I]);
        I := I+1
      end
  end;

{!getlist.p!}
  { getlist -- get list of line nums at lin[i], increment i }
  function GETLIST(var LIN : STRINGZ;
                   var I : Integer;
                   var STATUS : STCODE) : STCODE;
  var
    NUM : Integer;
    DONE : Boolean;
  begin
    LINE2 := 0;
    NLINES := 0;
    DONE := (GETONE(LIN, I, NUM, STATUS) <> OK);
    while (not DONE) do
      begin
        LINE1 := LINE2;
        LINE2 := NUM;
        NLINES := NLINES+1;
        if (LIN[I] = SEMICOL) then
          CURLN := NUM;
        if ((LIN[I] = COMMA) or
            (LIN[I] = SEMICOL)) then
          begin
            I := I+1;
            DONE := (GETONE(LIN, I, NUM, STATUS) <> OK)
          end
        else
          DONE := True
      end;
    NLINES := MIN(NLINES, 2);
    if (NLINES = 0) then
      LINE2 := CURLN;
    if (NLINES <= 1) then
      LINE1 := LINE2;
    if (STATUS <> ERR) then
      STATUS := OK;
    GETLIST := STATUS
  end;

{!getone.p!}
  { getone -- get one line number expression }
  function GETONE(var LIN : STRINGZ;
                  var I, NUM : Integer;
                  var STATUS : STCODE) : STCODE;
  var
    ISTART, MUL, PNUM : Integer;
  begin
    ISTART := I;
    NUM := 0;
    if (GETNUM(LIN, I, NUM, STATUS) = OK) then { 1st term }
      repeat                    { + or - terms }
        SKIPBL(LIN, I);
        if ((LIN[I] <> PLUS) and
            (LIN[I] <> MINUS)) then
          STATUS := ENDDATA
        else
          begin
            if (LIN[I] = PLUS) then
              MUL := +1
            else
              MUL := -1;
            I := I+1;
            if (GETNUM(LIN, I, PNUM, STATUS) = OK) then
              NUM := NUM+MUL*PNUM;
            if (STATUS = ENDDATA) then
              STATUS := ERR
          end
      until (STATUS <> OK);
    if ((NUM < 0) or
        (NUM > LASTLN)) then
      STATUS := ERR;
    if (STATUS <> ERR) then
      begin
        if (I <= ISTART) then
          STATUS := ENDDATA
        else
          STATUS := OK
      end;
    GETONE := STATUS
  end;

{!skipbl.p!}
  { skipbl -- skip blanks and tabs at s[i]... }
  procedure SKIPBL(var S : STRINGZ;
                   var I : Integer);
  begin
    while ((S[I] = BLANK) or
           (S[I] = TAB)) do
      I := I+1
  end;

{!getnum.p!}
  { getnum -- get single line number component }
  function GETNUM(var LIN : STRINGZ;
                  var I, NUM : Integer;
                  var STATUS : STCODE) : STCODE;
  begin
    STATUS := OK;
    SKIPBL(LIN, I);
    if (ISDIGIT(LIN[I])) then
      begin
        NUM := CTOI(LIN, I);
        I := I-1                { move back; to be advanced at end }
      end
    else if (LIN[I] = CURLINE) then
      NUM := CURLN
    else if (LIN[I] = LASTLINE) then
      NUM := LASTLN
    else if ((LIN[I] = SCAN) or
             (LIN[I] = BACKSCAN)) then
      begin
        if (OPTPAT(LIN, I) = ERR) then { build pattern }
          STATUS := ERR
        else
          STATUS := PATSCAN(LIN[I], NUM)
      end
    else
      STATUS := ENDDATA;
    if (STATUS = OK) then
      I := I+1;                 { next character to be examined }
    GETNUM := STATUS
  end;

{!optpat.p!}
  { optpat -- get optional pattern from lin[i], increment i }
  function OPTPAT(var LIN : STRINGZ;
                  var I : Integer) : STCODE;

#include "makepat.p"
  begin
    if (LIN[I] = ENDSTR) then
      I := 0
    else if (LIN[I+1] = ENDSTR) then
      I := 0
    else if (LIN[I+1] = LIN[I]) then { repeated delimiter }
      I := I+1                  { leave existing pattern alone }
    else
      I := MAKEPAT(LIN, I+1, LIN[I], PAT);
    if (PAT[1] = ENDSTR) then
      I := 0;
    if (I = 0) then
      begin
        PAT[1] := ENDSTR;
        OPTPAT := ERR
      end
    else
      OPTPAT := OK
  end;

{!patscan.p!}
  { patscan -- find next occurrence of pattern after line n }
  function PATSCAN(WAY : CHARACTER;
                   var N : Integer) : STCODE;
  var
    DONE : Boolean;
    LINE : STRINGZ;
  begin
    N := CURLN;
    PATSCAN := ERR;
    DONE := False;
    repeat
      if (WAY = SCAN) then
        N := NEXTLN(N)
      else
        N := PREVLN(N);
      GETTXT(N, LINE);
      if (MATCH(LINE, PAT)) then
        begin
          PATSCAN := OK;
          DONE := True
        end
    until ((N = CURLN) or
           (DONE))
  end;

{!nextln.p!}
  { nextln -- get line after n }
  function NEXTLN(N : Integer) : Integer;
  begin
    if (N >= LASTLN) then
      NEXTLN := 0
    else
      NEXTLN := N+1
  end;

{!prevln.p!}
  { prevln -- get line before n }
  function PREVLN(N : Integer) : Integer;
  begin
    if (N <= 0) then
      PREVLN := LASTLN
    else
      PREVLN := N-1
  end;

{!default.p!}
  { default -- set defaulted line numbers }
  function DEFAULT(DEF1, DEF2 : Integer;
                   var STATUS : STCODE) : STCODE;
  begin
    if (NLINES = 0) then
      begin
        LINE1 := DEF1;
        LINE2 := DEF2
      end;
    if ((LINE1 > LINE2) or
        (LINE1 <= 0)) then
      STATUS := ERR
    else
      STATUS := OK;
    DEFAULT := STATUS
  end;

{!doprint.p!}
  { doprint -- print lines n1 through n2 }
  function DOPRINT(N1, N2 : Integer) : STCODE;
  var
    I : Integer;
    LINE : STRINGZ;
  begin
    if (N1 <= 0) then
      DOPRINT := ERR
    else
      begin
        for I := N1 to N2 do
          begin
            GETTXT(I, LINE);
            PUTSTR(LINE, STDOUT)
          end;
        CURLN := N2;
        DOPRINT := OK
      end
  end;

{!appendz.p!}
  { appendz -- append lines after "line" }
  function APPENDZ(LINE : Integer;
                   GLOB : Boolean) : STCODE;
  var
    INLINEZ : STRINGZ;
    STAT : STCODE;
    DONE : Boolean;
  begin
    if (GLOB) then
      STAT := ERR
    else
      begin
        CURLN := LINE;
        STAT := OK;
        DONE := False;
        while ((not DONE) and
               (STAT = OK)) do
          if (not GETLINE(INLINEZ, STDIN, MAXSTR)) then
            STAT := ENDDATA
          else if (INLINEZ[1] = PERIOD)
          and (INLINEZ[2] = NEWLINE) then
            DONE := True
          else if (PUTTXT(INLINEZ) = ERR) then
            STAT := ERR
      end;
    APPENDZ := STAT
  end;

{!clrbuf1.p!}
  { clrbuf -- (in memory) initialize for new file }
  procedure CLRBUF;
  begin
    { nothing to do }
  end;

{!gettxt1.p!}
  { gettxt -- (in memory) get text from line n into s }
  procedure GETTXT(N : Integer;
                   var S : STRINGZ);
  begin
    SCOPY(BUF[N].TXT, 1, S, 1)
  end;

{!blkmove.p!}
  { blkmove -- move block of lines n1..n2 to after n3 }
  procedure BLKMOVE(N1, N2, N3 : Integer);
  begin
    if (N3 < N1-1) then
      begin
        REVERSE(N3+1, N1-1);
        REVERSE(N1, N2);
        REVERSE(N3+1, N2)
      end
    else if (N3 > N2) then
      begin
        REVERSE(N1, N2);
        REVERSE(N2+1, N3);
        REVERSE(N1, N3)
      end
  end;

{!reverse.p!}
  { reverse -- reverse buf[n1]...buf[n2] }
  procedure REVERSE(N1, N2 : Integer);
  var
    TEMP : BUFTYPE;
  begin
    while (N1 < N2) do
      begin
        TEMP := BUF[N1];
        BUF[N1] := BUF[N2];
        BUF[N2] := TEMP;
        N1 := N1+1;
        N2 := N2-1
      end
  end;

{!setbuf1.p!}
  { setbuf -- (in memory) initialize line storage buffer }
  procedure SETBUF;
  var
    NULL : STRINGZ;             { value is '' }
  begin
    NULL[1] := ENDSTR;
    SCOPY(NULL, 1, BUF[0].TXT, 1);
    CURLN := 0;
    LASTLN := 0;
  end;

{!puttxt1.p!}
  { puttxt -- (in memory) put text from lin after curln }
  function PUTTXT(var LIN : STRINGZ) : STCODE;
  begin
    PUTTXT := ERR;
    if (LASTLN < MAXLINES) then
      begin
        LASTLN := LASTLN+1;
        SCOPY(LIN, 1, BUF[LASTLN].TXT, 1);
        PUTMARK(LASTLN, False);
        BLKMOVE(LASTLN, LASTLN, CURLN);
        CURLN := CURLN+1;
        PUTTXT := OK
      end
  end;

{!ckp.p!}
  { ckp -- check for "p" after command }
  function CKP(var LIN : STRINGZ;
               I : Integer;
               var PFLAG : Boolean;
               var STATUS : STCODE) : STCODE;
  begin
    SKIPBL(LIN, I);
    if (LIN[I] = PCMD) then
      begin
        I := I+1;
        PFLAG := True
      end
    else
      PFLAG := False;
    if (LIN[I] = NEWLINE) then
      STATUS := OK
    else
      STATUS := ERR;
    CKP := STATUS
  end;

{!lndelete.p!}
  { lndelete -- delete lines n1 through n2 }
  function LNDELETE(N1, N2 : Integer;
                    var STATUS : STCODE) : STCODE;
  begin
    if (N1 <= 0) then
      STATUS := ERR
    else
      begin
        BLKMOVE(N1, N2, LASTLN);
        LASTLN := LASTLN-(N2-N1+1);
        CURLN := PREVLN(N1);
        STATUS := OK
      end;
    LNDELETE := STATUS
  end;

{!movez.p!}
  { movez -- move line1 through line2 after line3 }
  function MOVEZ(LINE3 : Integer) : STCODE;
  begin
    if ((LINE1 <= 0) or
        ((LINE3 >= LINE1) and
         (LINE3 < LINE2))) then
      MOVEZ := ERR
    else
      begin
        BLKMOVE(LINE1, LINE2, LINE3);
        if (LINE3 > LINE1) then
          CURLN := LINE3
        else
          CURLN := LINE3+(LINE2-LINE1+1);
        MOVEZ := OK
      end
  end;

{!getrhs.p!}
  { getrhs -- get right hand side of "s" command }
  function GETRHS(var LIN : STRINGZ;
                  var I : Integer;
                  var SUB : STRINGZ;
                  var GFLAG : Boolean) : STCODE;
  begin
    GETRHS := OK;
    if (LIN[I] = ENDSTR) then
      GETRHS := ERR
    else if (LIN[I+1] = ENDSTR) then
      GETRHS := ERR
    else
      begin
        I := MAKESUB(LIN, I+1, LIN[I], SUB);
        if (I = 0) then
          GETRHS := ERR
        else if (LIN[I+1] = Ord('g')) then
          begin
            I := I+1;
            GFLAG := True
          end
        else
          GFLAG := False
      end
  end;

{!subst.p!}
  { subst -- substitute "sub" for occurrences of pattern }
  function SUBST(var SUB : STRINGZ;
                 GFLAG, GLOB : Boolean) : STCODE;
  var
    NEWZ, OLD : STRINGZ;
    J, K, LASTM, LINE, M : Integer;
    STAT : STCODE;
    DONE, SUBBED, JUNK : Boolean;
  begin
    if (GLOB) then
      STAT := OK
    else
      STAT := ERR;
    DONE := (LINE1 <= 0);
    LINE := LINE1;
    while ((not DONE) and
           (LINE <= LINE2)) do
      begin
        J := 1;
        SUBBED := False;
        GETTXT(LINE, OLD);
        LASTM := 0;
        K := 1;
        while (OLD[K] <> ENDSTR) do
          begin
            if ((GFLAG) or
                (not SUBBED)) then
              M := AMATCH(OLD, K, PAT, 1)
            else
              M := 0;
            if ((M > 0) and
                (LASTM <> M)) then
              begin
                { replace matched text }
                SUBBED := True;
                CATSUB(OLD, K, M, SUB, NEWZ, J, MAXSTR);
                LASTM := M
              end;
            if ((M = 0) or
                (M = K)) then
              begin
                { no match or null match }
                JUNK := ADDSTR(OLD[K], NEWZ, J, MAXSTR);
                K := K+1
              end
            else                { skipped matched text }
              K := M
          end;
        if (SUBBED) then
          begin
            if (not ADDSTR(ENDSTR, NEWZ, J, MAXSTR)) then
              begin
                STAT := ERR;
                DONE := True
              end
            else
              begin
                STAT := LNDELETE(LINE, LINE, STATUS);
                STAT := PUTTXT(NEWZ);
                LINE2 := LINE2+CURLN-LINE;
                LINE := CURLN;
                if (STAT = ERR) then
                  DONE := True
                else
                  STAT := OK
              end
          end;
        LINE := LINE+1
      end;
    SUBST := STAT
  end;

{!catsub.p!}
  { catsub -- add replacement text to end of new }
  procedure CATSUB(var LIN : STRINGZ;
                   S1, S2 : Integer;
                   var SUB : STRINGZ;
                   var NEWZ : STRINGZ;
                   var K : Integer;
                   MAXNEW : Integer);
  var
    I, J : Integer;
    JUNK : Boolean;
  begin
    I := 1;
    while (SUB[I] <> ENDSTR) do
      begin
        if (SUB[I] = DITTO) then
          for J := S1 to S2-1 do
            JUNK := ADDSTR(LIN[J], NEWZ, K, MAXNEW)
        else
          JUNK := ADDSTR(SUB[I], NEWZ, K, MAXNEW);
        I := I+1
      end
  end;

{!getfn.p!}
  { getfn -- get file name from lin[i]... }
  function GETFN(var LIN : STRINGZ;
                 var I : Integer;
                 var FIL : STRINGZ) : STCODE;
  var
    K : Integer;
    STAT : STCODE;

#include "getword.p"
  begin
    STAT := ERR;
    if (LIN[I+1] = BLANK) then
      begin
        K := GETWORD(LIN, I+2, FIL); { get new filename }
        if (K > 0) then
          if (LIN[K] = NEWLINE) then
            STAT := OK
      end
    else if ((LIN[I+1] = NEWLINE) and
             (SAVEFILE[1] <> ENDSTR)) then
      begin
        SCOPY(SAVEFILE, 1, FIL, 1);
        STAT := OK;
      end;
    if ((STAT = OK) and
        (SAVEFILE[1] = ENDSTR)) then
      SCOPY(FIL, 1, SAVEFILE, 1); { save if no old one }
    GETFN := STAT
  end;

{!doread.p!}
  { doread -- read "fil" after line n }
  function DOREAD(N : Integer;
                  var FIL : STRINGZ) : STCODE;
  var
    COUNT : Integer;
    T : Boolean;
    STAT : STCODE;
    FD : FILEDESC;
    INLINEZ : STRINGZ;
  begin
    FD := OPEN(FIL, IOREAD);
    if (FD = IOERROR) then
      STAT := ERR
    else
      begin
        CURLN := N;
        STAT := OK;
        COUNT := 0;
        repeat
          T := GETLINE(INLINEZ, FD, MAXSTR);
          if (T) then
            begin
              STAT := PUTTXT(INLINEZ);
              if (STAT <> ERR) then
                COUNT := COUNT+1
            end
        until ((STAT <> OK) or
               (T = False));
        CLOSEZ(FD);
        PUTDEC(COUNT, 1);
        PUTC(NEWLINE)
      end;
    DOREAD := STAT
  end;

{!dowrite.p!}
  { dowrite -- write lines n1..n2 into file }
  function DOWRITE(N1, N2 : Integer;
                   var FIL : STRINGZ) : STCODE;
  var
    I : Integer;
    FD : FILEDESC;
    LINE : STRINGZ;
  begin
    FD := CREATE(FIL, IOWRITE);
    if (FD = IOERROR) then
      DOWRITE := ERR
    else
      begin
        for I := N1 to N2 do
          begin
            GETTXT(I, LINE);
            PUTSTR(LINE, FD)
          end;
        CLOSEZ(FD);
        PUTDEC(N2-N1+1, 1);
        PUTC(NEWLINE);
        DOWRITE := OK
      end
  end;

{!ckglob.p!}
  { ckglob -- if global prefix, mark lines to be affected }
  function CKGLOB(var LIN : STRINGZ;
                  var I : Integer;
                  var STATUS : STCODE) : STCODE;
  var
    N : Integer;
    GFLAG : Boolean;
    TEMP : STRINGZ;
  begin
    if ((LIN[I] <> GCMD) and
        (LIN[I] <> XCMD)) then
      STATUS := ENDDATA
    else
      begin
        GFLAG := (LIN[I] = GCMD);
        I := I+1;
        if (OPTPAT(LIN, I) = ERR) then
          STATUS := ERR
        else if (DEFAULT(1, LASTLN, STATUS) <> ERR) then
          begin
            I := I+1;           { mark affected lines }
            for N := LINE1 to LINE2 do
              begin
                GETTXT(N, TEMP);
                PUTMARK(N, (MATCH(TEMP, PAT) = GFLAG))
              end;
            for N := 1 to LINE1-1 do { erase other marks }
              PUTMARK(N, False);
            for N := LINE2+1 to LASTLN do
              PUTMARK(N, False);
            STATUS := OK
          end
      end;
    CKGLOB := STATUS
  end;

{!getmark.p!}
  { getmark -- get mark from nth line }
  function GETMARK(N : Integer) : Boolean;
  begin
    GETMARK := BUF[N].MARKZ
  end;

{!putmark.p!}
  { putmark -- put mark m on nth line }
  procedure PUTMARK(N : Integer;
                    M : Boolean);
  begin
    BUF[N].MARKZ := M
  end;

{!doglob.p!}
  { doglob -- do command at lin[i] on all marked lines }
  function DOGLOB(var LIN : STRINGZ;
                  var I, CURSAVE : Integer;
                  var STATUS : STCODE) : STCODE;
  var
    COUNT, ISTART, N : Integer;
  begin
    STATUS := OK;
    COUNT := 0;
    N := LINE1;
    ISTART := I;
    repeat
      if (GETMARK(N)) then
        begin
          PUTMARK(N, False);
          CURLN := N;
          CURSAVE := CURLN;
          I := ISTART;
          if (DOCMD(LIN, I, True, STATUS) = OK) then
            COUNT := 0
        end
      else
        begin
          N := NEXTLN(N);
          COUNT := COUNT+1
        end
    until ((COUNT > LASTLN) or
           (STATUS <> OK));
    DOGLOB := STATUS
  end;

{!docmd.p!}
  { docmd -- handle all commands except globals }
  function DOCMD(var LIN : STRINGZ;
                 var I : Integer;
                 GLOB : Boolean;
                 var STATUS : STCODE) : STCODE;
  var
    FIL, SUB : STRINGZ;
    LINE3 : Integer;
    GFLAG, PFLAG : Boolean;
  begin
    PFLAG := False;             { may be set by d, m, s }
    STATUS := ERR;
    if (LIN[I] = PCMD) then
      begin
        if (LIN[I+1] = NEWLINE) then
          if (DEFAULT(CURLN, CURLN, STATUS) = OK) then
            STATUS := DOPRINT(LINE1, LINE2)
      end
    else if (LIN[I] = NEWLINE) then
      begin
        if (NLINES = 0) then
          LINE2 := NEXTLN(CURLN);
        STATUS := DOPRINT(LINE2, LINE2)
      end
    else if (LIN[I] = QCMD) then
      begin
        if ((LIN[I+1] = NEWLINE) and
            (NLINES = 0) and
            (not GLOB)) then
          STATUS := ENDDATA
      end
    else if (LIN[I] = ACMD) then
      begin
        if (LIN[I+1] = NEWLINE) then
          STATUS := APPENDZ(LINE2, GLOB)
      end
    else if (LIN[I] = CCMD) then
      begin
        if (LIN[I+1] = NEWLINE) then
          if (DEFAULT(CURLN, CURLN, STATUS) = OK) then
            if (LNDELETE(LINE1, LINE2, STATUS) = OK) then
              STATUS := APPENDZ(PREVLN(LINE1), GLOB)
      end
    else if (LIN[I] = DCMD) then
      begin
        if (CKP(LIN, I+1, PFLAG, STATUS) = OK) then
          if (DEFAULT(CURLN, CURLN, STATUS) = OK) then
            if (LNDELETE(LINE1, LINE2, STATUS) = OK) then
              if (NEXTLN(CURLN) <> 0) then
                CURLN := NEXTLN(CURLN)
      end
    else if (LIN[I] = ICMD) then
      begin
        if (LIN[I+1] = NEWLINE) then
          begin
            if (LINE2 = 0) then
              STATUS := APPENDZ(0, GLOB)
            else
              STATUS := APPENDZ(PREVLN(LINE2), GLOB)
          end
      end
    else if (LIN[I] = EQCMD) then
      begin
        if (CKP(LIN, I+1, PFLAG, STATUS) = OK) then
          begin
            PUTDEC(LINE2, 1);
            PUTC(NEWLINE)
          end
      end
    else if (LIN[I] = MCMD) then
      begin
        I := I+1;
        if (GETONE(LIN, I, LINE3, STATUS) = ENDDATA) then
          STATUS := ERR;
        if (STATUS = OK) then
          if (CKP(LIN, I, PFLAG, STATUS) = OK) then
            if (DEFAULT(CURLN, CURLN, STATUS) = OK) then
              STATUS := MOVEZ(LINE3)
      end
    else if (LIN[I] = SCMD) then
      begin
        I := I+1;
        if (OPTPAT(LIN, I) = OK) then
          if (GETRHS(LIN, I, SUB, GFLAG) = OK) then
            if (CKP(LIN, I+1, PFLAG, STATUS) = OK) then
              if (DEFAULT(CURLN, CURLN, STATUS) = OK) then
                STATUS := SUBST(SUB, GFLAG, GLOB)
      end
    else if (LIN[I] = ECMD) then
      begin
        if (NLINES = 0) then
          if (GETFN(LIN, I, FIL) = OK) then
            begin
              SCOPY(FIL, 1, SAVEFILE, 1);
              CLRBUF;
              SETBUF;
              STATUS := DOREAD(0, FIL)
            end
      end
    else if (LIN[I] = FCMD) then
      begin
        if (NLINES = 0) then
          if (GETFN(LIN, I, FIL) = OK) then
            begin
              SCOPY(FIL, 1, SAVEFILE, 1);
              PUTSTR(SAVEFILE, STDOUT);
              PUTC(NEWLINE);
              STATUS := OK
            end
      end
    else if (LIN[I] = RCMD) then
      begin
        if (GETFN(LIN, I, FIL) = OK) then
          STATUS := DOREAD(LINE2, FIL)
      end
    else if (LIN[I] = WCMD) then
      begin
        if (GETFN(LIN, I, FIL) = OK) then
          if (DEFAULT(1, LASTLN, STATUS) = OK) then
            STATUS := DOWRITE(LINE1, LINE2, FIL)
      end;
    { else status is ERR }
    if ((STATUS = OK) and
        (PFLAG)) then
      STATUS := DOPRINT(CURLN, CURLN);
    DOCMD := STATUS
  end;

{!edit1.p!}
  { edit -- main routine for text editor }
  procedure EDIT;

#include "editcons.p"
#include "edittyp1.p"
#include "editvar1.p"
    CURSAVE, I : Integer;
    STATUS : STCODE;
    MORE : Boolean;

#include "editpro1.p"
  begin
    SETBUF;
    PAT[1] := ENDSTR;
    SAVEFILE[1] := ENDSTR;
    if (GETARG(1, SAVEFILE, MAXSTR)) then
      if (DOREAD(0, SAVEFILE) = ERR) then
        MESSAGE('?');
    MORE := GETLINE(LIN, STDIN, MAXSTR);
    while (MORE) do
      begin
        I := 1;
        CURSAVE := CURLN;
        if (GETLIST(LIN, I, STATUS) = OK) then
          begin
            if (CKGLOB(LIN, I, STATUS) = OK) then
              STATUS := DOGLOB(LIN, I, CURSAVE, STATUS)
            else if (STATUS <> ERR) then
              STATUS := DOCMD(LIN, I, False, STATUS)
                        { else ERR, do nothing }
          end;
        if (STATUS = ERR) then
          begin
            MESSAGE('?');
            CURLN := MIN(CURSAVE, LASTLN)
          end
        else if (STATUS = ENDDATA) then
          MORE := False;
        { else OK }
        if (MORE) then
          MORE := GETLINE(LIN, STDIN, MAXSTR)
      end;
    CLRBUF
  end;

{!editvar1.p!}
  { editvar -- (in-memory) variables for edit }
var
  BUF : array[0..MAXLINES] of BUFTYPE;

  LINE1 : Integer;              { first line number }
  LINE2 : Integer;              { second line number }
  NLINES : Integer;             { # of line numbers specified }
  CURLN : Integer;              { current line - value of dot }
  LASTLN : Integer;             { last line - value of $ }

  PAT : STRINGZ;                { pattern }
  LIN : STRINGZ;                { input line }
  SAVEFILE : STRINGZ;           { remembered file name }

{!editpro1.p!}
  { editproc -- procedures for edit }

#include "edprim1.p"            {editor buffer primitives }
#include "amatch.p"
#include "match.p"
#include "skipbl.p"
#include "optpat.p"
#include "nextln.p"
#include "prevln.p"
#include "patscan.p"
#include "getnum.p"
#include "getone.p"
#include "getlist.p"
#include "appendz.p"
#include "lndelete.p"
#include "doprint.p"
#include "doread.p"
#include "dowrite.p"
#include "movez.p"
#include "makesub.p"
#include "getrhs.p"
#include "catsub.p"
#include "subst.p"
#include "ckp.p"
#include "default.p"
#include "getfn.p"
#include "docmd.p"
#include "ckglob.p"
#include "doglob.p"

{!edprim1.p!}
  { edprim -- editor buffer primitives }

#include "setbuf1.p"
#include "clrbuf1.p"
#include "reverse.p"
#include "blkmove.p"
#include "putmark.p"
#include "getmark.p"
#include "puttxt1.p"
#include "gettxt1.p"

{!editcons.p!}
  { editcons -- const declarations for edit }
const
  MAXLINES = 100;               { set small for testing }
  MAXPAT = MAXSTR;
  CLOSIZE = 1;                  { size of a closure entry }
  DITTO = 255;                  {TP7}
  CLOSURE = STAR;
  BOL = PERCENT;
  EOL = DOLLAR;
  ANY = QUESTION;
  CCL = LBRACK;
  CCLEND = RBRACK;
  NEGATE = CARET;
  NCCL = EXCLAM;
  LITCHAR = Ord('c');
  CURLINE = PERIOD;
  LASTLINE = DOLLAR;
  SCAN = Ord('/');
  BACKSCAN = Ord('\');

  ACMD = Ord('a');
  CCMD = Ord('c');
  DCMD = Ord('d');
  ECMD = Ord('e');
  EQCMD = EQUALS;
  FCMD = Ord('f');
  GCMD = Ord('g');
  ICMD = Ord('i');
  MCMD = Ord('m');
  PCMD = Ord('p');
  QCMD = Ord('q');
  RCMD = Ord('r');
  SCMD = Ord('s');
  WCMD = Ord('w');
  XCMD = Ord('x');

{!edittyp1.p!}
  { edittype -- types for in-memory version of edit }
type
  STCODE = (ENDDATA, ERR, OK);  { status returns }
  BUFTYPE = record              { in-memory edit buffer entry }
              TXT : STRINGZ;    { text of line }
              MARKZ : Boolean;  { mark for line }
            end;

{!edprim2.p!}
  { edprim -- (scratch file) editor buffer primitives }

#include "setbuf2.p"
#include "clrbuf2.p"
#include "reverse.p"
#include "blkmove.p"
#include "putmark.p"
#include "getmark.p"
#include "puttxt2.p"
#include "gettxt2.p"

{!edittyp2.p!}
  { edittype -- types for scratch-file of edit }
type
  STCODE = (ENDDATA, ERR, OK);
  BUFTYPE = record
              TXT : Integer;    { text of line }
              MARKZ : Boolean;  { mark for line }
            end;

{!editvar2.p!}
  { editvar -- (scratch file) variables for edit }
var
  BUF : array[0..MAXLINES] of BUFTYPE;

  LINE1 : Integer;              { first line number }
  LINE2 : Integer;              { second line number }
  NLINES : Integer;             { # of line numbers specified }
  CURLN : Integer;              { current line - value of dot }
  LASTLN : Integer;             { last line - value of $ }

  PAT : STRINGZ;                { pattern }
  LIN : STRINGZ;                { input line }
  SAVEFILE : STRINGZ;           { remembered file name }

  SCROUT : FILEDESC;            { scratch input fd }
  SCRIN : FILEDESC;             { scratch output fd }
  RECIN : Integer;              { next record to read from scrin }
  RECOUT : Integer;             { next record to write on scrout }
  EDITTEMP : STRINGZ;           { temp file name 'edtemp' }

{!puttxt2.p!}
  { puttxt -- (scratch file) put text from lin after curln }
  function PUTTXT(var LIN : STRINGZ) : STCODE;
  begin
    PUTTXT := ERR;
    if (LASTLN < MAXLINES) then
      begin
        LASTLN := LASTLN+1;
        PUTSTR(LIN, SCROUT);
        PUTMARK(LASTLN, False);
        BUF[LASTLN].TXT := RECOUT;
        RECOUT := RECOUT+1;
        BLKMOVE(LASTLN, LASTLN, CURLN);
        CURLN := CURLN+1;
        PUTTXT := OK
      end
  end;

{!gettxt2.p!}
  { gettxt -- (scratch file) get text from line n into s }
  procedure GETTXT(N : Integer;
                   var S : STRINGZ);
  var
    JUNK : Boolean;

#include "seekz.p"
  begin
    if (N = 0) then
      S[1] := ENDSTR
    else
      begin
        SEEKZ(BUF[N].TXT, SCRIN);
        RECIN := RECIN+1;
        JUNK := GETLINE(S, SCRIN, MAXSTR)
      end
  end;

{!setbuf2.p!}
  { setbuf -- (scratch file) create scratch file, set up line 0 }
  procedure SETBUF;
  begin
    { setstring(edittemp, 'edtemp'); }
    EDITTEMP[1] := Ord('e');
    EDITTEMP[2] := Ord('d');
    EDITTEMP[3] := Ord('t');
    EDITTEMP[4] := Ord('e');
    EDITTEMP[5] := Ord('m');
    EDITTEMP[6] := Ord('p');
    EDITTEMP[7] := ENDSTR;
    SCROUT := MUSTCREATE(EDITTEMP, IOWRITE);
    SCRIN := MUSTOPEN(EDITTEMP, IOREAD);
    RECOUT := 1;
    RECIN := 1;
    CURLN := 0;
    LASTLN := 0;
  end;

{!clrbuf2.p!}
  { clrbuf -- (scratch file) initialize for new file }
  procedure CLRBUF;
  begin
    CLOSEZ(SCRIN);
    CLOSEZ(SCROUT);
    REMOVE(EDITTEMP)
  end;

{!edit2.p!}
  { edit -- main routine for text editor }
  procedure EDIT;

#include "editcons.p"
#include "edittyp2.p"
#include "editvar2.p"
    CURSAVE, I : Integer;
    STATUS : STCODE;
    MORE : Boolean;

#include "editpro2.p"
  begin
    SETBUF;
    PAT[1] := ENDSTR;
    SAVEFILE[1] := ENDSTR;
    if (GETARG(1, SAVEFILE, MAXSTR)) then
      if (DOREAD(0, SAVEFILE) = ERR) then
        MESSAGE('?');
    MORE := GETLINE(LIN, STDIN, MAXSTR);
    while (MORE) do
      begin
        I := 1;
        CURSAVE := CURLN;
        if (GETLIST(LIN, I, STATUS) = OK) then
          begin
            if (CKGLOB(LIN, I, STATUS) = OK) then
              STATUS := DOGLOB(LIN, I, CURSAVE, STATUS)
            else if (STATUS <> ERR) then
              STATUS := DOCMD(LIN, I, False, STATUS)
                        { else ERR, do nothing }
          end;
        if (STATUS = ERR) then
          begin
            MESSAGE('?');
            CURLN := MIN(CURSAVE, LASTLN)
          end
        else if (STATUS = ENDDATA) then
          MORE := False;
        { else OK }
        if (MORE) then
          MORE := GETLINE(LIN, STDIN, MAXSTR)
      end;
    CLRBUF
  end;

{!editpro2.p!}
  { editproc -- procedures for edit }

#include "edprim2.p"            {editor buffer primitives }
#include "amatch.p"
#include "match.p"
#include "skipbl.p"
#include "optpat.p"
#include "nextln.p"
#include "prevln.p"
#include "patscan.p"
#include "getnum.p"
#include "getone.p"
#include "getlist.p"
#include "appendz.p"
#include "lndelete.p"
#include "doprint.p"
#include "doread.p"
#include "dowrite.p"
#include "movez.p"
#include "makesub.p"
#include "getrhs.p"
#include "catsub.p"
#include "subst.p"
#include "ckp.p"
#include "default.p"
#include "getfn.p"
#include "docmd.p"
#include "ckglob.p"
#include "doglob.p"

{!command.p!}
  { command -- perform formatting command }
  procedure COMMAND(var BUF : STRINGZ);
  var
    CMD : CMDTYPE;
    ARGTYPE, SPVAL, VALZ : Integer;
  begin
    CMD := GETCMD(BUF);
    if (CMD <> UNKNOWN) then
      VALZ := GETVAL(BUF, ARGTYPE);
    case CMD of
      FI :
        begin
          BREAKZ;
          FILL := True
        end;
      NF :
        begin
          BREAKZ;
          FILL := False
        end;
      BR :
        BREAKZ;
      LS :
        SETPARAM(LSVAL, VALZ, ARGTYPE, 1, 1, HUGE);
      CE :
        begin
          BREAKZ;
          SETPARAM(CEVAL, VALZ, ARGTYPE, 1, 0, HUGE)
        end;
      UL :
        SETPARAM(ULVAL, VALZ, ARGTYPE, 1, 0, HUGE);
      HE :
        GETTL(BUF, HEADER);
      FO :
        GETTL(BUF, FOOTER);
      BP :
        begin
          PAGE;
          SETPARAM(CURPAGE, VALZ, ARGTYPE, CURPAGE+1, -HUGE, HUGE);
          NEWPAGE := CURPAGE
        end;
      SP :
        begin
          SETPARAM(SPVAL, VALZ, ARGTYPE, 1, 0, HUGE);
          SPACE(SPVAL)
        end;
      IND :
        SETPARAM(INVAL, VALZ, ARGTYPE, 0, 0, RMVAL-1);
      RM :
        SETPARAM(INVAL, VALZ, ARGTYPE, PAGEWIDTH, INVAL+TIVAL+1, HUGE);
      TI :
        begin
          BREAKZ;
          SETPARAM(TIVAL, VALZ, ARGTYPE, 0, -HUGE, RMVAL)
        end;
      PL :
        begin
          SETPARAM(PLVAL, VALZ, ARGTYPE, PAGELEN,
                   M1VAL+M2VAL+M3VAL+M4VAL+1, HUGE);
          BOTTOM := PLVAL-M3VAL-M4VAL
        end;
      UNKNOWN :
        { ignore }
    end
  end;

{!getcmd.p!}
  { getcmd -- decode command type }
  function GETCMD(var BUF : STRINGZ) : CMDTYPE;
  var
    CMD : packed array[1..2] of Char;
  begin
    CMD[1] := Chr(BUF[2]);
    CMD[2] := Chr(BUF[3]);
    if (CMD = 'fi') then
      GETCMD := FI
    else if (CMD = 'nf') then
      GETCMD := NF
    else if (CMD = 'br') then
      GETCMD := BR
    else if (CMD = 'ls') then
      GETCMD := LS
    else if (CMD = 'bp') then
      GETCMD := BP
    else if (CMD = 'sp') then
      GETCMD := SP
    else if (CMD = 'in') then
      GETCMD := IND
    else if (CMD = 'rm') then
      GETCMD := RM
    else if (CMD = 'ce') then
      GETCMD := CE
    else if (CMD = 'ti') then
      GETCMD := TI
    else if (CMD = 'ul') then
      GETCMD := UL
    else if (CMD = 'he') then
      GETCMD := HE
    else if (CMD = 'fo') then
      GETCMD := FO
    else if (CMD = 'pl') then
      GETCMD := PL
    else
      GETCMD := UNKNOWN
  end;

{!getval.p!}
  { getval -- evaluate optional numeric argument }
  function GETVAL(var BUF : STRINGZ;
                  var ARGTYPE : Integer) : Integer;
  var
    I : Integer;
  begin
    I := 1;                     { skip over command name }
    while (not(BUF[I] in [BLANK, TAB, NEWLINE])) do
      I := I+1;
    SKIPBL(BUF, I);             { find argument }
    ARGTYPE := BUF[I];
    if ((ARGTYPE = PLUS) or
        (ARGTYPE = MINUS)) then
      I := I+1;
    GETVAL := CTOI(BUF, I)
  end;

{!setparam.p!}
  { setparam -- set parameter and check range }
  procedure SETPARAM(var PARAM : Integer;
                     VALZ, ARGTYPE, DEFVAL, MINVAL, MAXVAL : Integer);
  begin
    if (ARGTYPE = NEWLINE) then { defaulted }
      PARAM := DEFVAL
    else if (ARGTYPE = PLUS) then { relative + }
      PARAM := PARAM+VALZ
    else if (ARGTYPE = MINUS) then { relative - }
      PARAM := PARAM-VALZ
    else                        { absolute }
      PARAM := VALZ;
    PARAM := MIN(PARAM, MAXVAL);
    PARAM := MAX(PARAM, MINVAL)
  end;

{!textz1.p!}
  { textz -- process text lines (interim version 1) }
  procedure TEXTZ(var INBUF : STRINGZ);
  begin
    PUT(INBUF)
  end;

{!put.p!}
  { put -- put out line with proper spacing and indenting }
  procedure PUT(var BUF : STRINGZ);
  var
    I : Integer;
  begin
    if ((LINENO <= 0) or
        (LINENO > BOTTOM)) then
      PUTHEAD;
    for I := 1 to INVAL+TIVAL do { indenting }
      PUTC(BLANK);
    TIVAL := 0;
    PUTSTR(BUF, STDOUT);
    SKIP(MIN(LSVAL-1, BOTTOM-LINENO));
    LINENO := LINENO+LSVAL;
    if (LINENO > BOTTOM) then
      PUTFOOT
  end;

{!puthead.p!}
  { puthead -- put out page header }
  procedure PUTHEAD;
  begin
    CURPAGE := NEWPAGE;
    NEWPAGE := NEWPAGE+1;
    if (M1VAL > 0) then
      begin
        SKIP(M1VAL-1);
        PUTTL(HEADER, CURPAGE)
      end;
    SKIP(M2VAL);
    LINENO := M1VAL+M2VAL+1
  end;

{!putfoot.p!}
  { putfoot -- put out page footer }
  procedure PUTFOOT;
  begin
    SKIP(M3VAL);
    if (M4VAL > 0) then
      begin
        PUTTL(FOOTER, CURPAGE);
        SKIP(M4VAL-1)
      end
  end;

{!puttl.p!}
  { puttl -- put out title line with optional page number }
  procedure PUTTL(var BUF : STRINGZ;
                  PAGENO : Integer);
  var
    I : Integer;
  begin
    for I := 1 to LENGTHZ(BUF) do
      if (BUF[I] = PAGENUM) then
        PUTDEC(PAGENO, 1)
      else
        PUTC(BUF[I])
  end;

{!gettl.p!}
  { gettl -- copy title from buf to ttl }
  procedure GETTL(var BUF, TTL : STRINGZ);
  var
    I : Integer;
  begin
    I := 1;                     { skip command name }
    while (not(BUF[I] in [BLANK, TAB, NEWLINE])) do
      I := I+1;
    SKIPBL(BUF, I);             { find argument }
    if (BUF[I] = SQUOTE) or (BUF[I] = DQUOTE) then
      I := I+1;                 { strip leading quote }
    SCOPY(BUF, I, TTL, 1)
  end;

{!space.p!}
  { space -- space n lines or to bottom of page }
  procedure SPACE(N : Integer);
  begin
    BREAKZ;
    if (LINENO <= BOTTOM) then
      begin
        if (LINENO <= 0) then
          PUTHEAD;
        SKIP(MIN(N, BOTTOM+1-LINENO));
        LINENO := LINENO+N;
        if (LINENO > BOTTOM) then
          PUTFOOT
      end
  end;

{!page.p!}
  { page -- get to top of new page }
  procedure PAGE;
  begin
    BREAKZ;
    if ((LINENO > 0) and
        (LINENO <= BOTTOM)) then
      begin
        SKIP(BOTTOM+1-LINENO);
        PUTFOOT
      end;
    LINENO := 0
  end;

{!leadbl.p!}
  { leadbl -- delete leading blanks, set tival }
  procedure LEADBL(var BUF : STRINGZ);
  var
    I, J : Integer;
  begin
    BREAKZ;
    I := 1;
    while (BUF[I] = BLANK) do   { find 1st non-blank }
      I := I+1;
    if (BUF[I] <> NEWLINE) then
      TIVAL := TIVAL+I-1;
    for J := I to LENGTHZ(BUF)+1 do { move line to left }
      BUF[J-I+1] := BUF[J]
  end;

{!textz2.p!}
  { textz -- process text lines (interim version 2) }
  procedure TEXTZ(var INBUF : STRINGZ);
  var
    WORDBUF : STRINGZ;
    I : Integer;
  begin
    if ((INBUF[1] = BLANK) or
        (INBUF[1] = NEWLINE)) then
      LEADBL(INBUF);            { move left, set tival }
    if (INBUF[1] = NEWLINE) then { all blank line }
      PUT(INBUF)
    else if (not FILL) then     { unfilled text }
      PUT(INBUF)
    else
      begin                     { filled text }
        I := 1;
        repeat
          I := GETWORD(INBUF, I, WORDBUF);
          if (I > 0) then
            PUTWORD(WORDBUF)
        until (I = 0)
      end
  end;

{!putword1.p!}
  { putword -- put word in outbuf }
  procedure PUTWORD(var WORDBUF : STRINGZ);
  var
    LAST, LLVAL, NEXTRA, W : Integer;
  begin
    W := WIDTH(WORDBUF);
    LAST := LENGTHZ(WORDBUF)+OUTP+1; { new end of outbuf }
    LLVAL := RMVAL-TIVAL-INVAL;
    if ((OUTP > 0) and
        ((OUTW+W > LLVAL) or
         (LAST >= MAXSTR))) then
      begin
        LAST := LAST-OUTP;      { remember end of wordbuf }
        BREAKZ                  { flush previous line }
      end;
    SCOPY(WORDBUF, 1, OUTBUF, OUTP+1);
    OUTP := LAST;
    OUTBUF[OUTP] := BLANK;      { blank between words }
    OUTW := OUTW+W+1;           { 1 for blank }
    OUTWDS := OUTWDS+1
  end;

{!width.p!}
  { width -- compute width of character string }
  function WIDTH(var BUF : STRINGZ) : Integer;
  var
    I, W : Integer;
  begin
    W := 0;
    I := 1;
    while (BUF[I] <> ENDSTR) do
      begin
        if (BUF[I] = BACKSPACE) then
          W := W-1
        else if (BUF[I] <> NEWLINE) then
          W := W+1;
        I := I+1
      end;
    WIDTH := W
  end;

{!breakz.p!}
  { breakz -- end current filled line }
  procedure BREAKZ;
  begin
    if (OUTP > 0) then
      begin
        OUTBUF[OUTP] := NEWLINE;
        OUTBUF[OUTP+1] := ENDSTR;
        PUT(OUTBUF)
      end;
    OUTP := 0;
    OUTW := 0;
    OUTWDS := 0
  end;

{!putword.p!}
  { putword -- put word in outbuf, does margin justification }
  procedure PUTWORD(var WORDBUF : STRINGZ);
  var
    LAST, LLVAL, NEXTRA, W : Integer;
  begin
    W := WIDTH(WORDBUF);
    LAST := LENGTHZ(WORDBUF)+OUTP+1;
    LLVAL := RMVAL-TIVAL-INVAL;
    if ((OUTP > 0) and
        ((OUTW+W > LLVAL) or
         (LAST >= MAXSTR))) then
      begin
        LAST := LAST-OUTP;      { remember end of wordbuf }
        NEXTRA := LLVAL-OUTW+1;
        if ((NEXTRA > 0) and
            (OUTWDS > 1)) then
          begin
            SPREAD(OUTBUF, OUTP, NEXTRA, OUTWDS);
            OUTP := OUTP+NEXTRA
          end;
        BREAKZ                  { flush previous line }
      end;
    SCOPY(WORDBUF, 1, OUTBUF, OUTP+1);
    OUTP := LAST;
    OUTBUF[OUTP] := BLANK;      { blank between words }
    OUTW := OUTW+W+1;           { 1 for blank }
    OUTWDS := OUTWDS+1
  end;

{!spread.p!}
  { spread -- spread words to justify right margin }
  procedure SPREAD(var BUF : STRINGZ;
                   OUTP, NEXTRA, OUTWDS : Integer);
  var
    I, J, NB, NHOLES : Integer;
  begin
    if ((NEXTRA > 0) and
        (OUTWDS > 1)) then
      begin
        DIR := 1-DIR;           { reverse previous direction }
        NHOLES := OUTWDS-1;
        I := OUTP-1;
        J := MIN(MAXSTR-2, I+NEXTRA); { room fore NEWLINE }
        while (I < J) do
          begin                 { end ENDSTR }
            BUF[J] := BUF[I];
            if (BUF[I] = BLANK) then
              begin
                if (DIR = 0) then
                  NB := (NEXTRA-1) div NHOLES+1
                else NB := NEXTRA div NHOLES;
                NEXTRA := NEXTRA-NB;
                NHOLES := NHOLES-1;
                while (NB > 0) do
                  begin
                    J := J-1;
                    BUF[J] := BLANK;
                    NB := NB-1
                  end
              end;
            I := I-1;
            J := J-1
          end
      end
  end;

{!center.p!}
  { center -- center a line by setting tival }
  procedure CENTER(var BUF : STRINGZ);
  begin
    TIVAL := MAX((RMVAL+TIVAL-WIDTH(BUF)) div 2, 0)
  end;

{!underln.p!}
  { underln -- underline a line }
  procedure UNDERLN(var BUF : STRINGZ;
                    SIZE : Integer);
  var
    I, J : Integer;
    TBUF : STRINGZ;
  begin
    J := 1;                     { expand into tbuf }
    I := 1;
    while ((BUF[I] <> NEWLINE) and
           (J < SIZE-1)) do
      begin
        if (ISALPHANUM(BUF[I])) then
          begin
            TBUF[J] := UNDERLINE;
            TBUF[J+1] := BACKSPACE;
            J := J+2
          end;
        TBUF[J] := BUF[I];
        J := J+1;
        I := I+1
      end;
    TBUF[J] := NEWLINE;
    TBUF[J+1] := ENDSTR;
    SCOPY(TBUF, 1, BUF, 1)      { copy it back to buf }
  end;

{!textz.p!}
  { textz -- process text lines (final version) }
  procedure TEXTZ(var INBUF : STRINGZ);
  var
    WORDBUF : STRINGZ;
    I : Integer;
  begin
    if ((INBUF[1] = BLANK) or
        (INBUF[1] = NEWLINE)) then
      LEADBL(INBUF);            { move left, set tival }
    if (ULVAL > 0) then
      begin                     { underlining }
        UNDERLN(INBUF, MAXSTR);
        ULVAL := ULVAL-1
      end;
    if (CEVAL > 0) then
      begin                     { centering }
        CENTER(INBUF);
        PUT(INBUF);
        CEVAL := CEVAL-1
      end
    else if (INBUF[1] = NEWLINE) then { all-blank line }
      PUT(INBUF)
    else if (not FILL) then     { unfilled text }
      PUT(INBUF)
    else
      begin                     { filled text }
        I := 1;
        repeat
          I := GETWORD(INBUF, I, WORDBUF);
          if (I > 0) then
            PUTWORD(WORDBUF)
        until (I = 0)
      end
  end;

{!format.p!}
  { format -- text formatter main program (final version) }
  procedure FORMAT;

#include "fmtcons.p"
  type
    CMDTYPE = (BP, BR, CE, FI, FO, HE, IND, LS, NF, PL,
               RM, SP, TI, UL, UNKNOWN);
  var
    { page parameters }
    CURPAGE : Integer;          { current output page number; init=0 }
    NEWPAGE : Integer;          { next output page number; init=1 }
    LINENO : Integer;           { next line to be printed; init=0 }
    PLVAL : Integer;            { page length in lines; init=PAGELEN=66 }
    M1VAL : Integer;            { margin before and including header }
    M2VAL : Integer;            { margin after header }
    M3VAL : Integer;            { margin after last text line }
    M4VAL : Integer;            { bottom margin, including footer }
    BOTTOM : Integer;           { last line on page, =plval-m3val-m4val }
    HEADER : STRINGZ;           { top of page title; init=NEWLINE }
    FOOTER : STRINGZ;           { bottom of page title; init=NEWLINE }

    { global parameters }
    FILL : Boolean;             { fill if true; init=true }
    LSVAL : Integer;            { current line spacing; init=1 }
    SPVAL : Integer;            { # of lines to space }
    INVAL : Integer;            { current indent; >= 0; init=0 }
    RMVAL : Integer;            { right margin; init=PAGEWIDTH=60 }
    TIVAL : Integer;            { current temporary indent; init=0 }
    CEVAL : Integer;            { # of lines to center; init=0 }
    ULVAL : Integer;            { # of lines to underline; init=0 }

    { output area }
    OUTP : Integer;             { last char pos in outbuf; init=0 }
    OUTW : Integer;             { width of text in outbuf; init=0 }
    OUTWDS : Integer;           { number of words in outbuf; init=0 }
    OUTBUF : STRINGZ;           { lines to be filled collect here }
    DIR : 0..1;                 { direction for blank padding }
    INBUF : STRINGZ;            { input line }

#include "fmtproc.p"
  begin
    INITFMT;
    while (GETLINE(INBUF, STDIN, MAXSTR)) do
      if (INBUF[1] = CMD) then
        COMMAND(INBUF)
      else
        TEXTZ(INBUF);
    PAGE
  end;

{!initfmt.p!}
  { initfmt -- set format parameters to default values }
  procedure INITFMT;
  begin
    FILL := True;
    DIR := 0;
    INVAL := 0;
    RMVAL := PAGEWIDTH;
    TIVAL := 0;
    LSVAL := 1;
    SPVAL := 0;
    CEVAL := 0;
    ULVAL := 0;
    LINENO := 0;
    CURPAGE := 0;
    NEWPAGE := 1;
    PLVAL := PAGELEN;
    M1VAL := 3; M2VAL := 2; M3VAL := 2; M4VAL := 3;
    BOTTOM := PLVAL-M3VAL-M4VAL;
    HEADER[1] := NEWLINE;       { initial titles }
    HEADER[2] := ENDSTR;
    FOOTER[1] := NEWLINE;
    FOOTER[2] := ENDSTR;
    OUTP := 0;
    OUTW := 0;
    OUTWDS := 0
  end;

{!fmtcons.p!}
  { fmtcons -- constants for format }
const
  CMD = PERIOD;
  PAGENUM = SHARP;
  PAGEWIDTH = 60;
  PAGELEN = 66;
  HUGE = 10000;

{!fmtproc.p!}
  { fmtproc -- procedures needed for format }

#include "skipbl.p"
#include "skip.p"
#include "getcmd.p"
#include "setparam.p"
#include "getval.p"
#include "gettl.p"
#include "puttl.p"
#include "puthead.p"
#include "putfoot.p"
#include "width.p"
#include "put.p"
#include "breakz.p"
#include "space.p"
#include "page.p"
#include "leadbl.p"
#include "spread.p"
#include "putword.p"
#include "getword.p"
#include "center.p"
#include "underln.p"
#include "initfmt.p"
#include "command.p"
#include "textz.p"

{!gettok.p!}
  { gettok -- get token for define }
  function GETTOK(var TOKEN : STRINGZ;
                  TOKSIZE : Integer) : CHARACTER;
  var
    I : Integer;
    DONE : Boolean;
  begin
    I := 1;
    DONE := False;
    while ((not DONE) and
           (I < TOKSIZE)) do
      if (ISALPHANUM(GETPBC(TOKEN[I]))) then
        I := I+1
      else
        DONE := True;
    if (I >= TOKSIZE) then
      ERROR('define: token too long');
    if (I > 1) then
      begin                     { some alpha was seen }
        PUTBACK(TOKEN[I]);
        I := I-1
      end;
    { else single non-alphanumeric }
    TOKEN[I+1] := ENDSTR;
    GETTOK := TOKEN[1]
  end;

{!putback.p!}
  { putback -- push character back onto input }
  procedure PUTBACK(C : CHARACTER);
  begin
    if (BP >= BUFSIZE) then
      ERROR('too many characters pushed back');
    BP := BP+1;
    BUF[BP] := C
  end;

{!getpbc.p!}
  { getpbc -- get a (possibly pushed back) character }
  function GETPBC(var C : CHARACTER) : CHARACTER;
  begin
    if (BP > 0) then
      C := BUF[BP]
    else
      begin
        BP := 1;
        BUF[BP] := GETC(C)
      end;
    if (C <> ENDFILE) then
      BP := BP-1;
    GETPBC := C
  end;

{!pbstr.p!}
  { pbstr -- push string back onto input }
  procedure PBSTR(var S : STRINGZ);
  var
    I : Integer;
  begin
    for I := LENGTHZ(S) downto 1 do
      PUTBACK(S[I])
  end;

{!define.p!}
  { define -- simple string replacement macro preprocessor }
  procedure DEFINE;

#include "defcons.p"
#include "deftype.p"
#include "defvar.p"
    DEFN : STRINGZ;
    TOKEN : STRINGZ;
    TOKTYPE : STTYPE;           { type returned by lookup }
    DEFNAME : STRINGZ;          { value is 'defined' }
    NULL : STRINGZ;             { value is '' }

#include "defproc.p"
  begin
    NULL[1] := ENDSTR;
    INITDEF;
    INSTALL(DEFNAME, NULL, DEFTYPE);
    while (GETTOK(TOKEN, MAXTOK) <> ENDFILE) do
      if (not ISLETTER(TOKEN[1])) then
        PUTSTR(TOKEN, STDOUT)
      else if (not LOOKUP(TOKEN, DEFN, TOKTYPE)) then
        PUTSTR(TOKEN, STDOUT)   { undefined }
      else if (TOKTYPE = DEFTYPE) then
        begin                   { defs }
          GETDEF(TOKEN, MAXTOK, DEFN, MAXDEF);
          INSTALL(TOKEN, DEFN, MACTYPE)
        end
      else
        PBSTR(DEFN)             { push replacement onto input }
  end;

{!isletter.p!}
  { isletter -- true if c is a letter of either case }
  function ISLETTER(C : CHARACTER) : Boolean;
  begin
    ISLETTER := C in [Ord('a') ..Ord('z')]+[Ord('A') ..Ord('Z')]
  end;

{!getdef.p!}
  { getdef -- get name and definiations }
  procedure GETDEF(var TOKEN : STRINGZ;
                   TOKSIZE : Integer;
                   var DEFN : STRINGZ;
                   DEFSIZE : Integer);
  var
    I, NLPAR : Integer;
    C : CHARACTER;
  begin
    TOKEN[1] := ENDSTR;         { in case of bad input }
    DEFN[1] := ENDSTR;
    if (GETPBC(C) <> LPAREN) then
      MESSAGE('define: missing left paren')
    else if (not ISLETTER(GETTOK(TOKEN, TOKSIZE))) then
      MESSAGE('define : non-alphanumeric name')
    else if (GETPBC(C) <> COMMA) then
      MESSAGE('define: missing comma in define')
    else
      begin                     { got '(name,'' so far }
        while (GETPBC(C) = BLANK) do ; { skip leading blanks }
        PUTBACK(C);             { went one too far }
        NLPAR := 0;
        I := 1;
        while (NLPAR >= 0) do
          begin
            if (I >= DEFSIZE) then
              ERROR('define: definition too long')
            else if (GETPBC(DEFN[I]) = ENDFILE) then
              ERROR('define: missing right paren')
            else if (DEFN[I] = LPAREN) then
              NLPAR := NLPAR+1
            else if (DEFN[I] = RPAREN) then
              NLPAR := NLPAR-1;
            { else normal character in defn[i] }
            I := I+1;
          end;
        DEFN[I-1] := ENDSTR
      end
  end;

{!initdef.p!}
  { initdef -- initialize variables for define }
  procedure INITDEF;
  begin
    { setstring(defname, 'define'); }
    DEFNAME[1] := Ord('d');
    DEFNAME[2] := Ord('e');
    DEFNAME[3] := Ord('f');
    DEFNAME[4] := Ord('i');
    DEFNAME[5] := Ord('n');
    DEFNAME[6] := Ord('e');
    DEFNAME[7] := ENDSTR;
    BP := 0;                    { pushback buffer pointer }
    INITHASH;
  end;

{!deftype.p!}
  { deftype -- type definitions for define }
type
  CHARPOS = 1..MAXCHARS;
  CHARBUF = array[1..MAXCHARS] of CHARACTER;
  STTYPE = (DEFTYPE, MACTYPE);  { symbol table types }
  NDPTR = ^NDBLOCK;             { pointer to a name-defn block }
  NDBLOCK = record              { name-defn block }
              NAME : CHARPOS;
              DEFN : CHARPOS;
              KIND : STTYPE;
              NEXTPTR : NDPTR
            end;

{!defvar.p!}
  { defvar -- var declarations for define }
  var
    HASHTAB : array[1..HASHSIZE] of NDPTR;
    NDTABLE : CHARBUF;
    NEXTTAB : CHARPOS;          { first free position in ndtable }
    BUF : array[1..BUFSIZE] of CHARACTER; { for pushback }
    BP : 0..BUFSIZE;            { next available character; init=0 }

{!inithash.p!}
  { inithash -- initialize hash table to nil }
  procedure INITHASH;
  var
    I : 1..HASHSIZE;
  begin
    NEXTTAB := 1;               { first free slot in table }
    for I := 1 to HASHSIZE do
      HASHTAB[I] := nil
  end;

{!lookup.p!}
  { lookup -- locate name, get defn and type from table }
  function LOOKUP(var NAME, DEFN : STRINGZ;
                  var T : STTYPE) : Boolean;
  var
    P : NDPTR;
  begin
    P := HASHFIND(NAME);
    if (P = nil) then
      LOOKUP := False
    else
      begin
        LOOKUP := True;
        CSCOPY(NDTABLE, P^.DEFN, DEFN);
        T := P^.KIND
      end
  end;

{!hashfind.p!}
  { hashfind -- find name in hash table }
  function HASHFIND(var NAME : STRINGZ) : NDPTR;
  var
    P : NDPTR;
    TEMPNAME : STRINGZ;
    FOUND : Boolean;
  begin
    FOUND := False;
    P := HASHTAB[HASH(NAME)];
    while ((not FOUND) and
           (P <> nil)) do
      begin
        CSCOPY(NDTABLE, P^.NAME, TEMPNAME);
        if (EQUAL(NAME, TEMPNAME)) then
          FOUND := True
        else
          P := P^.NEXTPTR
      end;
    HASHFIND := P
  end;

{!hash.p!}
  { hash -- compute hash function of a name }
  function HASH(var NAME : STRINGZ) : Integer;
  var
    I, H : Integer;
  begin
    H := 0;
    for I := 1 to LENGTHZ(NAME) do
      H := (3*H+NAME[I]) mod HASHSIZE;
    HASH := H+1
  end;

{!install.p!}
  { install -- add name, definition and type to table }
  procedure INSTALL(var NAME, DEFN : STRINGZ;
                    T : STTYPE);
  var
    H, DLEN, NLEN : Integer;
    P : NDPTR;
  begin
    NLEN := LENGTHZ(NAME)+1;    { 1 for ENDSTR }
    DLEN := LENGTHZ(DEFN)+1;
    if (NEXTTAB+NLEN+DLEN > MAXCHARS) then
      begin
        PUTSTR(NAME, STDERR);
        ERROR(': too many definitions')
      end
    else
      begin                     { put it at front of chain }
        H := HASH(NAME);
        New(P);
        P^.NEXTPTR := HASHTAB[H];
        HASHTAB[H] := P;
        P^.NAME := NEXTTAB;
        SCCOPY(NAME, NDTABLE, NEXTTAB);
        NEXTTAB := NEXTTAB+NLEN;
        P^.DEFN := NEXTTAB;
        SCCOPY(DEFN, NDTABLE, NEXTTAB);
        NEXTTAB := NEXTTAB+DLEN;
        P^.KIND := T
      end
  end;

{!defcons.p!}
  { defcons -- const declarations for define }
  const
  BUFSIZE = 500;                { size of pushback buffer }
  MAXCHARS = 5000;              { size of name-defn table }
  MAXDEF = MAXSTR;              { max chars in a defn }
  MAXTOK = MAXSTR;              { max chars in a token }
  HASHSIZE = 53;                { size of hash table }

{!defproc.p!}
  { defproc -- procedures needed by define }

#include "cscopy.p"
#include "sccopy.p"
#include "putback.p"
#include "getpbc.p"
#include "pbstr.p"
#include "gettok.p"
#include "getdef.p"
#include "inithash.p"
#include "hash.p"
#include "hashfind.p"
#include "install.p"
#include "lookup.p"
#include "initdef.p"

{!macro.p!}
  { macro -- expand macros with arguments }
  procedure MACRO;

#include "maccons.p"
#include "mactype.p"
#include "macvar.p"
    DEFN : STRINGZ;
    TOKEN : STRINGZ;
    TOKTYPE : STTYPE;
    T : CHARACTER;
    NLPAR : Integer;

#include "macproc.p"
  begin
    INITMACRO;
    INSTALL(DEFNAME, NULL, DEFTYPE);
    INSTALL(EXPRNAME, NULL, EXPRTYPE);
    INSTALL(SUBNAME, NULL, SUBTYPE);
    INSTALL(IFNAME, NULL, IFTYPE);
    INSTALL(LENNAME, NULL, LENTYPE);
    INSTALL(CHQNAME, NULL, CHQTYPE);

    CP := 0;
    AP := 1;
    EP := 1;
    while (GETTOK(TOKEN, MAXTOK) <> ENDFILE) do
      if (ISLETTER(TOKEN[1])) then
        begin
          if (not LOOKUP(TOKEN, DEFN, TOKTYPE)) then
            PUTTOK(TOKEN)
          else
            begin               { defined; put it in eval stack }
              CP := CP+1;
              if (CP > CALLSIZE) then
                ERROR('macro: call stack overflow');
              CALLSTK[CP] := AP;
              TYPESTK[CP] := TOKTYPE;
              AP := PUSH(EP, ARGSTK, AP);
              PUTTOK(DEFN);     { push definition }
              PUTCHR(ENDSTR);
              AP := PUSH(EP, ARGSTK, AP);
              PUTTOK(TOKEN);    { stack name }
              PUTCHR(ENDSTR);
              AP := PUSH(EP,ARGSTK,AP);
              T := GETTOK(TOKEN,MAXTOK); { peek at next }
              PBSTR(TOKEN);
              if (T <> LPAREN) then
                begin           { add () }
                  PUTBACK(RPAREN);
                  PUTBACK(LPAREN)
                end;
              PLEV[CP] := 0
            end
        end
      else if (TOKEN[1] = LQUOTE) then
        begin                   { strip quotes }
          NLPAR := 1;
          repeat
            T := GETTOK(TOKEN, MAXTOK);
            if (T = RQUOTE) then
              NLPAR := NLPAR-1
            else if (T = LQUOTE) then
              NLPAR := NLPAR+1
            else if (T = ENDFILE) then
              ERROR('macro: missing right quote');
            if (NLPAR > 0) then
              PUTTOK(TOKEN)
          until (NLPAR = 0)
        end
      else if (CP = 0) then     { not in a macro at all }
        PUTTOK(TOKEN)
      else if (TOKEN[1] = LPAREN) then
        begin
          if (PLEV[CP] > 0) then
            PUTTOK(TOKEN);
          PLEV[CP] := PLEV[CP]+1
        end
      else if (TOKEN[1] = RPAREN) then
        begin
          PLEV[CP] := PLEV[CP]-1;
          if (PLEV[CP] > 0) then
            PUTTOK(TOKEN)
          else
            begin               { end of argument list }
              PUTCHR(ENDSTR);
              EVAL(ARGSTK, TYPESTK[CP], CALLSTK[CP], AP-1);
              AP := CALLSTK[CP]; { pop eval stack }
              EP := ARGSTK[AP];
              CP := CP-1
            end
        end
      else if ((TOKEN[1] = COMMA) and
               (PLEV[CP] = 1)) then
        begin
          PUTCHR(ENDSTR);       { new argument }
          AP := PUSH(EP, ARGSTK, AP)
        end
      else
        PUTTOK(TOKEN);          { just stack it }
    if (CP <> 0) then
      ERROR('macro: unexpected end of input')
  end;

{!puttok.p!}
  { puttok -- put token on output or evaluation stack }
  procedure PUTTOK(var S : STRINGZ);
  var
    I : Integer;
  begin
    I := 1;
    while (S[I] <> ENDSTR) do
      begin
        PUTCHR(S[I]);
        I := I+1
      end
  end;

{!putchr.p!}
  { putchr -- put single char on output or evaluation stack }
  procedure PUTCHR(C : CHARACTER);
  begin
    if (CP <= 0) then
      PUTC(C)
    else
      begin
        if (EP > EVALSIZE) then
          ERROR('macro: evaluation stack overflow');
        EVALSTK[EP] := C;
        EP := EP+1
      end
  end;

{!push.p!}
  { push -- push ep onto argstk, return new position ap }
  function PUSH(EP : Integer;
                var ARGSTK : POSBUF;
                AP : Integer) : Integer;
  begin
    if (AP > ARGSIZE) then
      ERROR('macro: argument stack overflow');
    ARGSTK[AP] := EP;
    PUSH := AP+1
  end;

{!eval.p!}
  { eval -- expand args i..j: do built-in or push back defn }
  procedure EVAL(var ARGSTK : POSBUF;
                 TD : STTYPE;
                 I, J : Integer);
  var
    ARGNO, K, T : Integer;
    TEMP : STRINGZ;
  begin
    T := ARGSTK[I];
    if (TD = DEFTYPE) then
      DODEF(ARGSTK, I, J)
    else if (TD = EXPRTYPE) then
      DOEXPR(ARGSTK, I, J)
    else if (TD = SUBTYPE) then
      DOSUB(ARGSTK, I, J)
    else if (TD = IFTYPE) then
      DOIF(ARGSTK, I, J)
    else if (TD = LENTYPE) then
      DOLEN(ARGSTK, I, J)
    else if (TD = CHQTYPE) then
      DOCHQ(ARGSTK, I, J)
    else
      begin
        K := T;
        while (EVALSTK[K] <> ENDSTR) do
          K := K+1;
        K := K-1;               { last character of defn }
        while (K > T) do
          begin
            if (EVALSTK[K-1] <> ARGFLAG) then
              PUTBACK(EVALSTK[K])
            else
              begin
                ARGNO := Ord(EVALSTK[K])-Ord('0');
                if ((ARGNO >= 0) and
                    (ARGNO < J-I)) then
                  begin
                    CSCOPY(EVALSTK, ARGSTK[I+ARGNO+1], TEMP);
                    PBSTR(TEMP)
                  end;
                K := K-1        { skip over $ }
              end;
            K := K-1
          end;
        if (K = T) then         { do last character }
          PUTBACK(EVALSTK[K])
      end
  end;

{!dodef.p!}
  { dodef -- install definitions in table }
  procedure DODEF(var ARGSTK : POSBUF;
                  I, J : Integer);
  var
    TEMP1, TEMP2 : STRINGZ;
  begin
    if (J-I > 2) then
      begin
        CSCOPY(EVALSTK, ARGSTK[I+2], TEMP1);
        CSCOPY(EVALSTK, ARGSTK[I+3], TEMP2);
        INSTALL(TEMP1, TEMP2, MACTYPE)
      end
  end;

{!doif.p!}
  { doif -- select one of two arguments }
  procedure DOIF(var ARGSTK : POSBUF;
                 I, J : Integer);
  var
    TEMP1, TEMP2, TEMP3 : STRINGZ;
  begin
    if (J-I >= 4) then
      begin
        CSCOPY(EVALSTK, ARGSTK[I+2], TEMP1);
        CSCOPY(EVALSTK, ARGSTK[I+3], TEMP2);
        if (EQUAL(TEMP1, TEMP2)) then
          CSCOPY(EVALSTK, ARGSTK[I+4], TEMP3)
        else if (J-I >= 5) then
          CSCOPY(EVALSTK, ARGSTK[I+5], TEMP3)
        else
          TEMP3[1] := ENDSTR;
        PBSTR(TEMP3)
      end
  end;

{!doexpr.p!}
  { doexpr -- evaluate arithmetic expressions }
  procedure DOEXPR(var ARGSTK : POSBUF;
                   I, J : Integer);
  var
    TEMP : STRINGZ;
    JUNK : Integer;
  begin
    CSCOPY(EVALSTK, ARGSTK[I+2], TEMP);
    JUNK := 1;
    PBNUM(EXPR(TEMP, JUNK))
  end;

{!pbnum.p!}
  { pbnum -- convert number to string, push back on input }
  procedure PBNUM(N : Integer);
  var
    TEMP : STRINGZ;
    JUNK : Integer;
  begin
    JUNK := ITOC(N, TEMP, 1);
    PBSTR(TEMP)
  end;

{!expr.p!}
  { expr -- recursive expression evaluation }
  function EXPR(var S : STRINGZ;
                var I : Integer) : Integer;
  var
    V : Integer;
    T : CHARACTER;

#include "gnbchar.p"
#include "term.p"
  begin
    V := TERM(S, I);
    T := GNBCHAR(S, I);
    while (T in [PLUS, MINUS]) do
      begin
        I := I+1;
        if (T = PLUS) then
          V := V+TERM(S, I)
        else
          V := V-TERM(S, I);
        T := GNBCHAR(S, I)
      end;
    EXPR := V
  end;

{!term.p!}
  { term -- evaluate term of arithmetic expression }
  function TERM(var S : STRINGZ;
                var I : Integer) : Integer;
  var
    V : Integer;
    T : CHARACTER;

#include "factor.p"
  begin
    V := FACTOR(S, I);
    T := GNBCHAR(S, I);
    while (T in [STAR, SLASH, PERCENT]) do
      begin
        I := I+1;
        case T of
          STAR :
            V := V*FACTOR(S, I);
          SLASH :
            V := V div FACTOR(S, I);
          PERCENT :
            V := V mod FACTOR(S, I)
        end;
        T := GNBCHAR(S, I)
      end;
    TERM := V
  end;

{!factor.p!}
  { factor -- evaluate factor of arithmetic expression }
  function FACTOR(var S : STRINGZ;
                  var I : Integer) : Integer;
  begin
    if (GNBCHAR(S, I) = LPAREN) then
      begin
        I := I+1;
        FACTOR := EXPR(S, I);
        if (GNBCHAR(S, I) = RPAREN) then
          I := I+1
        else
          WriteLn('macro: missing paren in expr')
      end
    else
      FACTOR := CTOI(S, I)
  end;

{!gnbchar.p!}
  { gnbchar -- get next non-blank character }
  function GNBCHAR(var S : STRINGZ;
                   var I : Integer) : CHARACTER;
  begin
    while (S[I] in [BLANK, TAB, NEWLINE]) do
      I := I+1;
    GNBCHAR := S[I]
  end;

{!dolen.p!}
  { dolen -- return length of argument }
  procedure DOLEN(var ARGSTK : POSBUF;
                  I, J : Integer);
  var
    TEMP : STRINGZ;
  begin
    if (J-I > 1) then
      begin
        CSCOPY(EVALSTK, ARGSTK[I+2], TEMP);
        PBNUM(LENGTHZ(TEMP))
      end
    else
      PBNUM(0)
  end;

{!dosub.p!}
  { dosub -- select substring }
  procedure DOSUB(var ARGSTK : POSBUF;
                  I, J : Integer);
  var
    AP, FC, K, NC : Integer;
    TEMP1, TEMP2 : STRINGZ;
  begin
    if (J-I >= 3) then
      begin
        if (J-I < 4) then
          NC := MAXTOK
        else
          begin
            CSCOPY(EVALSTK, ARGSTK[I+4], TEMP1);
            K := 1;
            NC := EXPR(TEMP1, K)
          end;
        CSCOPY(EVALSTK, ARGSTK[I+3], TEMP1); { origin }
        AP := ARGSTK[I+2];      { target string }
        K := 1;
        FC := AP+EXPR(TEMP1, K)-1; { first char }
        CSCOPY(EVALSTK, AP, TEMP2);
        if ((FC >= AP) and
            (FC < AP+LENGTHZ(TEMP2))) then
          begin
            CSCOPY(EVALSTK, FC, TEMP1);
            for K := FC+MIN(NC, LENGTHZ(TEMP1))-1 downto FC do
              PUTBACK(EVALSTK[K])
          end
      end
  end;

{!dochq.p!}
  { dochq -- change quote characters }
  procedure DOCHQ(var ARGSTK : POSBUF;
                  I, J : Integer);
  var
    TEMP : STRINGZ;
    N : Integer;
  begin
    CSCOPY(EVALSTK, ARGSTK[I+2], TEMP);
    N := LENGTHZ(TEMP);
    if (N <= 0) then
      begin
        LQUOTE := Ord(GRAVE);
        RQUOTE := Ord(ACUTE)
      end
    else if (N = 1) then
      begin
        LQUOTE := TEMP[1];
        RQUOTE := LQUOTE
      end
    else
      begin
        LQUOTE := TEMP[1];
        RQUOTE := TEMP[2]
      end
  end;

{!mactype.p!}
  { mactype -- type declarations for macro }
type
  CHARPOS = 1..MAXCHARS;
  CHARBUF = array[1..MAXCHARS] of CHARACTER;
  POSBUF = array[1..MAXPOS] of CHARPOS;
  POSZ = 0..MAXPOS;
  STTYPE = (DEFTYPE, MACTYPE, IFTYPE, SUBTYPE,
            EXPRTYPE, LENTYPE, CHQTYPE); { symbol table types }
  NDPTR = ^NDBLOCK;
  NDBLOCK = record
              NAME : CHARPOS;
              DEFN : CHARPOS;
              KIND : STTYPE;
              NEXTPTR : NDPTR
            end;

{!maccons.p!}
  { maccons -- const declarations for macro }
  const
  BUFSIZE = 1000;               { size of pushback buffer }
  MAXCHARS = 5000;              { size of name-defn table }
  MAXPOS = 500;                 { size of position arrays }
  CALLSIZE = MAXPOS;
  ARGSIZE = MAXPOS;
  EVALSIZE = MAXCHARS;
  MAXDEF = MAXSTR;              { max chars in a defn }
  MAXTOK = MAXSTR;              { max chars in a token }
  HASHSIZE = 53;                { size of hash table }
  ARGFLAG = DOLLAR;             { macro invocation character }

{!macvar.p!}
  { macvar -- var declarations for macro }
  var
    BUF : array[1..BUFSIZE] of CHARACTER; { for pushback }
    BP : 0..BUFSIZE;            { next available character; init=0 }

    HASHTAB : array[1..HASHSIZE] of NDPTR;
    NDTABLE : CHARBUF;
    NEXTTAB : CHARPOS;          { first free position in ndtable }

    CALLSTK : POSBUF;           { call stack }
    CP : POSZ;                  { current call stack position }
    TYPESTK : array[1..CALLSIZE] of STTYPE; { type }
    PLEV : array[1..CALLSIZE] of Integer; { paren level }
    ARGSTK : POSBUF;            { argument stack for this call }
    AP : POSZ;                  { current argument position }
    EVALSTK : CHARBUF;          { evaluation stack }
    EP : CHARPOS;               { first character unused in evalstk }

    { built-ins: }
    DEFNAME : STRINGZ;          { value is 'define' }
    EXPRNAME : STRINGZ;         { value is 'expr' }
    SUBNAME : STRINGZ;          { value is 'substr' }
    IFNAME : STRINGZ;           { value is 'ifelse' }
    LENNAME : STRINGZ;          { value is 'len' }
    CHQNAME : STRINGZ;          { vlaue is 'changeq' }

    NULL : STRINGZ;             { value is '' }
    LQUOTE : CHARACTER;         { left quote character }
    RQUOTE : CHARACTER;         { right quote character }

{!initmacr.p!}
  { initmacro -- initialize variables for macro }
  procedure INITMACRO;
  begin
    NULL[1] := ENDSTR;
    { setstring(defname, 'define'); }
    DEFNAME[1] := Ord('d');
    DEFNAME[2] := Ord('e');
    DEFNAME[3] := Ord('f');
    DEFNAME[4] := Ord('i');
    DEFNAME[5] := Ord('n');
    DEFNAME[6] := Ord('e');
    DEFNAME[7] := ENDSTR;
    { setstring(subname, 'substr'); }
    SUBNAME[1] := Ord('s');
    SUBNAME[2] := Ord('u');
    SUBNAME[3] := Ord('b');
    SUBNAME[4] := Ord('s');
    SUBNAME[5] := Ord('t');
    SUBNAME[6] := Ord('r');
    SUBNAME[7] := ENDSTR;
    { setstring(exprname, 'expr'); }
    EXPRNAME[1] := Ord('e');
    EXPRNAME[2] := Ord('x');
    EXPRNAME[3] := Ord('p');
    EXPRNAME[4] := Ord('r');
    EXPRNAME[5] := ENDSTR;
    { setstring(ifname, 'ifelse'); }
    IFNAME[1] := Ord('i');
    IFNAME[2] := Ord('f');
    IFNAME[3] := Ord('e');
    IFNAME[4] := Ord('l');
    IFNAME[5] := Ord('s');
    IFNAME[6] := Ord('e');
    IFNAME[7] := ENDSTR;
    { setstring(lenname, 'len'); }
    LENNAME[1] := Ord('l');
    LENNAME[2] := Ord('e');
    LENNAME[3] := Ord('n');
    LENNAME[4] := ENDSTR;
    { setstring(chqname, 'changeq'); }
    CHQNAME[1] := Ord('c');
    CHQNAME[2] := Ord('h');
    CHQNAME[3] := Ord('a');
    CHQNAME[4] := Ord('n');
    CHQNAME[5] := Ord('g');
    CHQNAME[6] := Ord('e');
    CHQNAME[7] := Ord('q');
    CHQNAME[8] := ENDSTR;
    BP := 0;                    { pushback buffer pointer }
    INITHASH;
    LQUOTE := Ord(GRAVE);
    RQUOTE := Ord(ACUTE)
  end;

{!macproc.p!}
{ macproc -- procedures for macro program }

#include "inithash.p"
#include "initmacr.p"
#include "hash.p"
#include "sccopy.p"
#include "install.p"
#include "getpbc.p"
#include "putback.p"
#include "gettok.p"
#include "cscopy.p"
#include "hashfind.p"
#include "lookup.p"
#include "putchr.p"
#include "puttok.p"
#include "push.p"
#include "pbstr.p"
#include "dodef.p"
#include "pbnum.p"
#include "expr.p"
#include "doexpr.p"
#include "dosub.p"
#include "doif.p"
#include "dolen.p"
#include "dochq.p"
#include "eval.p"

{!getc.p!}
  { getc -- (TP7) get one character from standard input }
  function GETC(var C : CHARACTER) : CHARACTER;
  var
    CH : Char;
  begin
    if (Eof) then
      C := ENDFILE
    else if (Eoln) then
      begin
        ReadLn;
        C := NEWLINE;
      end
    else
      begin
        Read(CH);
        C := Ord(CH);
      end;
    GETC := C;
  end;

{!putc.p!}
  { putc -- (TP7) put one character on standard output }
  procedure PUTC(C : CHARACTER);
  begin
    if (C = NEWLINE) then
      WriteLn
    else
      Write(Chr(C));
  end;

{!prims.p!}
  { prims -- (TP7) primitive functions and procedures }

#include "initio.p"
#include "open.p"
#include "create.p"
#include "getc.p"
#include "getcf.p"
#include "getline.p"
#include "putc.p"
#include "putcf.p"
#include "putstr.p"
#include "closez.p"
#include "remove.p"
#include "getarg.p"
#include "nargs.p"

{!utility.p!}
  { utility -- generally useful function and procedures }

#include "addstr.p"
#include "equal.p"
#include "esc.p"
#include "indexz.p"
#include "isalnum.p"
#include "isdigit.p"
#include "isletter.p"
#include "islower.p"
#include "isupper.p"
#include "itoc.p"
#include "lengthz.p"
#include "max.p"
#include "min.p"
#include "scopy.p"
#include "ctoi.p"
#include "fcopy.p"
#include "mustcrea.p"
#include "mustopen.p"
#include "putdec.p"

{!islower.p!}
  { islower -- true if c is lower case letter }
  function ISLOWER(C : CHARACTER) : Boolean;
  begin
    ISLOWER := C in [Ord('a') ..Ord('z')]
  end;

{!globdefs.p!}
  { globdefs -- global constants, types and variables }

const

  { standard file descriptors, subscripts in open, etc. }
  STDIN = 1;                    { these are not to be changed }
  STDOUT = 2;
  STDERR = 3;

  { other io-related stuff }
  IOERROR = 0;                  { status values for open files }
  IOAVAIL = 1;
  IOREAD = 2;
  IOWRITE = 3;
  MAXOPEN = 10;                 { maximum number of open files }

  { universal manifest constants }
  ENDFILE = 255;
  ENDSTR = 0;                   { null-terminated stringzs }
  MAXSTR = 100;                 { longest possible stringz }

  { ascii character set in decimal }
  BACKSPACE = 8;
  TAB = 9;
  NEWLINE = 10;                 { line feed }
  BLANK = Ord(' ');
  EXCLAM = Ord('!');
  DQUOTE = Ord('"');
  SHARP = Ord('#');
  DOLLAR = Ord('$');
  PERCENT = Ord('%');
  AMPER = Ord('&');
  SQUOTE = Ord('''');
  ACUTE = SQUOTE;
  LPAREN = Ord('(');
  RPAREN = Ord(')');
  STAR = Ord('*');
  PLUS = Ord('+');
  COMMA = Ord(',');
  MINUS = Ord('-');
  DASH = MINUS;
  PERIOD = Ord('.');
  SLASH = Ord('/');
  COLON = Ord(':');
  SEMICOL = Ord(';');
  LESS = Ord('<');
  EQUALS = Ord('=');
  GREATER = Ord('>');
  QUESTION = Ord('?');
  ATSIGN = Ord('@');
  LBRACK = Ord('[');
  BACKSLASH = Ord('\');
  RBRACK = Ord(']');
  CARET = Ord('^');
  UNDERLINE = Ord('_');
  GRAVE = Ord('`');
  LBRACE = Ord('{');
  BAR = Ord('|');
  RBRACE = Ord('}');
  TILDE = Ord('~');

type
  CHARACTER = Byte;             { byte-sized. ascii + other stuff }
  STRINGZ = array[1..MAXSTR] of CHARACTER;
  FILEDESC = IOERROR..MAXOPEN;
  IOBLOCK = record              { to keep track of open files }
              FILEVAR : Text;
              MODE : IOERROR..IOWRITE;
            end;

var
  OPENLIST : array[1..MAXOPEN] of IOBLOCK; { open files }

{!initio.p!}
  { initio -- (TP7) initialize open file list }
  procedure INITIO;
  var
    INDEX : Integer;
  begin
    OPENLIST[STDIN].MODE := IOREAD;
    OPENLIST[STDOUT].MODE := IOWRITE;
    OPENLIST[STDERR].MODE := IOWRITE;

    { connect STDERR to user's terminal ... }
    Assign(OPENLIST[STDERR].FILEVAR, '');
    Rewrite(OPENLIST[STDERR].FILEVAR);

    for INDEX := STDERR+1 to MAXOPEN do
      OPENLIST[INDEX].MODE := IOAVAIL;
  end;

{!open.p!}
  { open -- (TP7) make a file available for input or output }
  function OPEN(NAME : STRINGZ;
                MODE : Integer) : FILEDESC;
  var
    FILE_NAME : String[MAXSTR];
    INDEX : Integer;
    FOUND : Boolean;
  begin
    OPEN := IOERROR;
    if ((MODE = IOREAD) or
        (MODE = IOWRITE)) then
      begin
        INDEX := 1;
        while (NAME[INDEX] <> ENDSTR) do
          begin
            FILE_NAME[INDEX] := Chr(NAME[INDEX]);
            Inc(INDEX);
          end;
        FILE_NAME[0] := Chr(INDEX-1);
        { find a free slot in openlist }
        FOUND := False;
        INDEX := 1;
        while ((INDEX <= MAXOPEN) and
               (not FOUND)) do
          begin
            if (OPENLIST[INDEX].MODE = IOAVAIL) then
              begin
                OPENLIST[INDEX].MODE := MODE;
                Assign(OPENLIST[INDEX].FILEVAR, FILE_NAME);
                {$I-}
                if (MODE = IOREAD) then
                  Reset(OPENLIST[INDEX].FILEVAR)
                else
                  Rewrite(OPENLIST[INDEX].FILEVAR);
                {$I+}
                if (IoResult = 0) then
                  OPEN := INDEX;
                FOUND := True;
              end;
            Inc(INDEX);
          end;
      end;
  end;

{!create.p!}
  { create -- (TP7) make a new instance of a file available }
  function CREATE(NAME : STRINGZ;
                  MODE : Integer) : FILEDESC;
  var
    FILE_NAME : String[MAXSTR];
    INDEX : Integer;
    FOUND : Boolean;
  begin
    CREATE := IOERROR;
    if (MODE = IOWRITE) then
      begin
        INDEX := 1;
        while (NAME[INDEX] <> ENDSTR) do
          begin
            FILE_NAME[INDEX] := Chr(NAME[INDEX]);
            Inc(INDEX);
          end;
        FILE_NAME[0] := Chr(INDEX-1);
        { find a free slot in openlist }
        FOUND := False;
        INDEX := 1;
        while ((INDEX <= MAXOPEN) and
               (not FOUND)) do
          begin
            if (OPENLIST[INDEX].MODE = IOAVAIL) then
              begin
                OPENLIST[INDEX].MODE := MODE;
                Assign(OPENLIST[INDEX].FILEVAR, FILE_NAME);
                {$I-}
                Rewrite(OPENLIST[INDEX].FILEVAR);
                {$I+}
                if (IoResult = 0) then
                  CREATE := INDEX;
                FOUND := True;
              end;
            Inc(INDEX);
          end;
      end;
  end;

{!closez.p!}
  { closez -- (TP7) close a file and release slot }
  procedure CLOSEZ(FD : FILEDESC);
  begin
    if ((FD > STDERR) and
        (FD <= MAXOPEN)) then
      begin
        Close(OPENLIST[FD].FILEVAR);
        OPENLIST[FD].MODE := IOAVAIL;
      end;
  end;

{!remove.p!}
  { remove -- (TP7) remove a file }
  procedure REMOVE(NAME : STRINGZ);
  var
    INDEX : Integer;
    FILE_NAME : String[MAXSTR];
    FILE_VAR : file;
  begin
    INDEX := 1;
    while (NAME[INDEX] <> ENDSTR) do
      begin
        FILE_NAME[INDEX] := Chr(NAME[INDEX]);
        Inc(INDEX);
      end;
    FILE_NAME[0] := Chr(INDEX-1);
    { make sure file exists before removing it }
    Assign(FILE_VAR, FILE_NAME);
    Rewrite(FILE_VAR);
    Close(FILE_VAR);
    Erase(FILE_VAR);
  end;

{!getline.p!}
  { getline -- (TP7) get one line of text from a file }
  function GETLINE(var S : STRINGZ;
                   FD : FILEDESC;
                   MAXSIZE : Integer) : Boolean;
  var
    I : Integer;
    C : CHARACTER;
  begin
    I := 1;
    repeat
      S[I] := GETCF(C, FD);
      I := I+1;
    until ((C = ENDFILE) or
           (C = NEWLINE) or
           (I >= MAXSIZE));
    if (C = ENDFILE) then       { went one too far }
      I := I-1;
    S[I] := ENDSTR;
    GETLINE := (C <> ENDFILE);
  end;

{!putstr.p!}
  { putstr -- (TP7) put stringz in a file }
  procedure PUTSTR(var S : STRINGZ;
                   FD : FILEDESC);
  var
    I : Integer;
  begin
    I := 1;
    while (S[I] <> ENDSTR) do
      begin
        PUTCF(S[I], FD);
        I := I+1;
      end;
  end;

{!getcf.p!}
  { getcf -- (TP7) get one character from a file }
  function GETCF(var C : CHARACTER;
                 FD : FILEDESC) : CHARACTER;
  var
    CH : Char;
  begin
    if (FD = STDIN) then
      GETCF := GETC(C)
    else if Eof(OPENLIST[FD].FILEVAR) then
      C := ENDFILE
    else if Eoln(OPENLIST[FD].FILEVAR) then
      begin
        ReadLn(OPENLIST[FD].FILEVAR);
        C := NEWLINE;
      end
    else
      begin
        Read(OPENLIST[FD].FILEVAR, CH);
        C := Ord(CH);
      end;
    GETCF := C;
  end;

{!putcf.p!}
  { putcf -- (TP7) put a single character in a file }
  procedure PUTCF(C : CHARACTER;
                  FD : FILEDESC);
  begin
    if (FD = STDOUT) then
      PUTC(C)
    else if (C = NEWLINE) then
      WriteLn(OPENLIST[FD].FILEVAR)
    else
      Write(OPENLIST[FD].FILEVAR, Chr(C));
  end;

{!nargs.p!}
  { nargs -- (TP7) return number of arguments }
  function NARGS : Integer;
  begin
    if (NARG = -1) then
      PARSE_ARG;
    NARGS := NARG;
  end;

{!getarg.p!}
  { getarg -- (TP7) get n-th command line argument into s }
  function GETARG(N : Integer;
                  var S : STRINGZ;
                  MAXSIZE : Integer) : Boolean;
  var
    START, FINISH : Integer;
    SOURCE, DESTINATION, LEN, COUNT : Integer;
  begin
    if (NARG = -1) then
      PARSE_ARG;
    if ((N < 1) or
        (NARG < N)) then
      GETARG := False
    else
      begin
        START := ARGS[N, 1];
        FINISH := ARGS[N, 2];
        LEN := FINISH-START+1;
        if (MAXSIZE < LEN) then
          LEN := MAXSIZE;
        if (LEN >= 1) then
          begin
            DESTINATION := 1;
            SOURCE := START;
            COUNT := LEN;
            repeat
              S[DESTINATION] := Ord(CMD_TAIL[SOURCE]);
              Inc(DESTINATION);
              Inc(SOURCE);
              Dec(COUNT);
            until (COUNT = 0);
          end;
        S[LEN+1] := ENDSTR;
        GETARG := True;
      end;
  end;

{!seekz.p!}
  { seekz -- position file access pointer }
  procedure SEEKZ(RECNO : Integer;
                  FD : FILEDESC);
  var
    JUNK : Boolean;
    TEMP : STRINGZ;
  begin
    if (RECNO < RECIN) then
      begin
        CLOSEZ(FD);
        { cheat: open scratch file by name }
        FD := MUSTOPEN(EDITTEMP, IOREAD);
        RECIN := 1;
      end;
    while (RECIN < RECNO) do
      begin
        JUNK := GETLINE(TEMP, FD, MAXSTR);
        RECIN := RECIN+1
      end
  end;

{!error.p!}
  { error -- (TP7) print a message and exit program }
  procedure ERROR(S : String);
  begin
    WriteLn;
    WriteLn(S);
    Halt(0);
  end;

{!message.p!}
  { message -- (TP7) print a message and continue }
  procedure MESSAGE(S : String);
  begin
    WriteLn(S);
  end;

{!globdefs.i!}
{$I COMPILER.INC}
#include "header.p"
unit GLOBDEFS;

interface

#include "globdefs.p"
implementation
end.

{!prims.i!}
{$I COMPILER.INC}
#include "header.p"
unit PRIMS;

interface

uses GLOBDEFS;

procedure ERROR(S : String);
procedure MESSAGE(S : String);
procedure INITIO;
function OPEN(NAME : STRINGZ;
              MODE : Integer) : FILEDESC;
function CREATE(NAME : STRINGZ;
                MODE : Integer) : FILEDESC;
function GETC(var C : CHARACTER) : CHARACTER;
function GETCF(var C : CHARACTER;
               FD : FILEDESC) : CHARACTER;
function GETLINE(var S : STRINGZ;
                 FD : FILEDESC;
                 MAXSIZE : Integer) : Boolean;
procedure PUTC(C : CHARACTER);
procedure PUTCF(C : CHARACTER;
                FD : FILEDESC);
procedure PUTSTR(var S : STRINGZ;
                 FD : FILEDESC);
procedure CLOSEZ(FD : FILEDESC);
procedure REMOVE(NAME : STRINGZ);
function GETARG(N : Integer;
                var S : STRINGZ;
                MAXSIZE : Integer) : Boolean;
function NARGS : Integer;



implementation

  { TP7 command line argument declarations }
const
  MAX_ARGS = 64;
  NARG : Integer = -1;
var
  ARGS : array[1..MAX_ARGS, 1..2] of Integer;
  CMD_TAIL : String[127];


  { parse_arg -- parse command line arguments TP7 }
  procedure PARSE_ARG;
  {Split the command line tail into arguments using blanks as separators.
  If an argument requires embedded blanks, surround it with quotation
  marks (") which will be stripped off retaining the embedded blanks.}
  const
    DELIMITER = DQUOTE;
  type
    STR_PTR = ^String;
  var
    INDEX : Integer;
    C : CHARACTER;
    CMD_TAIL_LEN : Integer;     {length of command tail}
  begin
    CMD_TAIL := STR_PTR(Ptr(PrefixSeg, $80))^;
    NARG := 0;
    for INDEX := 1 to MAX_ARGS do
      begin
        ARGS[INDEX, 1] := 0;
        ARGS[INDEX, 2] := 0;
      end; { for }

    CMD_TAIL_LEN := Length(CMD_TAIL);
    if (CMD_TAIL_LEN <> 0) then
      begin
        INDEX := 1;
        repeat
          if (Ord(CMD_TAIL[INDEX]) <> BLANK) then
            begin
              Inc(NARG);

              if (Ord(CMD_TAIL[INDEX]) = DELIMITER) then
                begin
                  ARGS[NARG, 1] := INDEX+1;
                  C := DELIMITER;
                end
              else
                begin
                  ARGS[NARG, 1] := INDEX;
                  C := BLANK;
                end; { if }

              repeat
                Inc(INDEX);
              until ((Ord(CMD_TAIL[INDEX]) = C) or
                     (INDEX > CMD_TAIL_LEN));
              ARGS[NARG, 2] := INDEX-1;
            end; { if }
          Inc(INDEX);
        until (INDEX > CMD_TAIL_LEN);
      end; { if }
  end; { procedure }




  {------------------------------------------------}

#include "error.p"
#include "message.p"
#include "prims.p"
begin
  INITIO;
end.

{!utility.i!}
{$I COMPILER.INC}
#include "header.p"
unit UTILITY;

interface

uses GLOBDEFS;

function ADDSTR(C : CHARACTER;
                var OUTSET : STRINGZ;
                var J : Integer;
                MAXSET : Integer) : Boolean;
function EQUAL(var STR1, STR2 : STRINGZ) : Boolean;
function ESC(var S : STRINGZ;
             var I : Integer) : CHARACTER;
function INDEXZ(var S : STRINGZ;
                C : CHARACTER) : Integer;
function ISALPHANUM(C : CHARACTER) : Boolean;
function ISDIGIT(C : CHARACTER) : Boolean;
function ISLETTER(C : CHARACTER) : Boolean;
function ISLOWER(C : CHARACTER) : Boolean;
function ISUPPER(C : CHARACTER) : Boolean;
function ITOC(N : Integer;
              var S : STRINGZ;
              I : Integer) : Integer;
function LENGTHZ(var S : STRINGZ) : Integer;
function MAX(X, Y : Integer) : Integer;
function MIN(X, Y : Integer) : Integer;
procedure SCOPY(var SRC : STRINGZ;
                I : Integer;
                var DEST : STRINGZ;
                J : Integer);
function CTOI(var S : STRINGZ;
              var I : Integer) : Integer;
procedure FCOPY(FIN, FOUT : FILEDESC);
function MUSTCREATE(var NAME : STRINGZ;
                    MODE : Integer) : FILEDESC;
function MUSTOPEN(var NAME : STRINGZ;
                  MODE : Integer) : FILEDESC;
procedure PUTDEC(N, W : Integer);



implementation

uses PRIMS;

#include "utility.p"
end.

{!charcnt.i!}
{$I COMPILER.INC}
#include "header.p"

uses GLOBDEFS, PRIMS, UTILITY;

#include "charcnt.p"
begin
  CHARCOUNT;
end.

{!linecnt.i!}
{$I COMPILER.INC}
#include "header.p"
uses GLOBDEFS, PRIMS, UTILITY;

#include "linecnt.p"
begin
  LINECOUNT;
end.

{!wordcnt.i!}
{$I COMPILER.INC}
#include "header.p"
uses GLOBDEFS, PRIMS, UTILITY;

#include "wordcnt.p"
begin
  WORDCOUNT;
end.

{!detab.i!}
{$I COMPILER.INC}
#include "header.p"
uses GLOBDEFS, PRIMS, UTILITY;

#include "detab.p"
begin
  DETAB;
end.

{!entab.i!}
{$I COMPILER.INC}
#include "header.p"
uses GLOBDEFS, PRIMS, UTILITY;

#include "entab.p"
begin
  ENTAB;
end.

{!overstrk.i!}
{$I COMPILER.INC}
#include "header.p"
uses GLOBDEFS, PRIMS, UTILITY;

#include "overstrk.p"
begin
  OVERSTRIKE;
end.

{!compress.i!}
{$I COMPILER.INC}
#include "header.p"
uses GLOBDEFS, PRIMS, UTILITY;

#include "compress.p"
begin
  COMPRESS;
end.

{!expand.i!}
{$I COMPILER.INC}
#include "header.p"
uses GLOBDEFS, PRIMS, UTILITY;

#include "expand.p"
begin
  EXPAND;
end.

{!echoz.i!}
{$I COMPILER.INC}
#include "header.p"
uses GLOBDEFS, PRIMS, UTILITY;

#include "echo.p"
begin
  ECHO;
end.

{!translit.i!}
{$I COMPILER.INC}
#include "header.p"
uses GLOBDEFS, PRIMS, UTILITY;

#include "translit.p"
begin
  TRANSLIT;
end.

{!compare.i!}
{$I COMPILER.INC}
#include "header.p"
uses GLOBDEFS, PRIMS, UTILITY;

#include "compare.p"
begin
  COMPARE;
end.

{!include.i!}
{$I COMPILER.INC}
#include "header.p"
uses GLOBDEFS, PRIMS, UTILITY;

#include "includez.p"
begin
  INCLUDEZ;
end.

{!concat.i!}
{$I COMPILER.INC}
#include "header.p"
uses GLOBDEFS, PRIMS, UTILITY;

#include "concatz.p"
begin
  CONCATZ;
end.

{!printz.i!}
{$I COMPILER.INC}
#include "header.p"
uses GLOBDEFS, PRIMS, UTILITY;

#include "print.p"
begin
  PRINT;
end.

{!makecopy.i!}
{$I COMPILER.INC}
#include "header.p"
uses GLOBDEFS, PRIMS, UTILITY;

#include "makecopy.p"
begin
  MAKECOPY;
end.

{!archive.i!}
{$I COMPILER.INC}
#include "header.p"
uses GLOBDEFS, PRIMS, UTILITY;

#include "archive.p"
begin
  ARCHIVE;
end.

{!sortz.i!}
{$I COMPILER.INC}
#include "header.p"
uses GLOBDEFS, PRIMS, UTILITY;

#include "sort.p"
begin
  SORT;
end.

{!unique.i!}
{$I COMPILER.INC}
#include "header.p"
uses GLOBDEFS, PRIMS, UTILITY;

#include "unique.p"
begin
  UNIQUE;
end.

{!kwic.i!}
{$I COMPILER.INC}
#include "header.p"
uses GLOBDEFS, PRIMS, UTILITY;

#include "kwic.p"
begin
  KWIC;
end.

{!unrotate.i!}
{$I COMPILER.INC}
#include "header.p"
uses GLOBDEFS, PRIMS, UTILITY;

#include "unrotate.p"
begin
  UNROTATE;
end.

{!findz.i!}
{$I COMPILER.INC}
#include "header.p"
uses GLOBDEFS, PRIMS, UTILITY;

#include "find.p"
begin
  FIND;
end.

{!change.i!}
{$I COMPILER.INC}
#include "header.p"
uses GLOBDEFS, PRIMS, UTILITY;

#include "change.p"
begin
  CHANGE;
end.

{!edit1.i!}
{$I COMPILER.INC}
#include "header.p"
{$define INMEM}

uses GLOBDEFS, PRIMS, UTILITY;

#include "edit1.p"
begin
  EDIT;
end.

{!edit2.i!}
{$I COMPILER.INC}
#include "header.p"
{$define INMEM}

uses GLOBDEFS, PRIMS, UTILITY;

#include "edit2.p"
begin
  EDIT;
end.

{!formatz.i!}
{$I COMPILER.INC}
#include "header.p"
uses GLOBDEFS, PRIMS, UTILITY;

#include "format.p"
begin
  FORMAT;
end.

{!define.i!}
{$I COMPILER.INC}
#include "header.p"
uses GLOBDEFS, PRIMS, UTILITY;

#include "define.p"
begin
  DEFINE;
end.

{!macro.i!}
{$I COMPILER.INC}
#include "header.p"
uses GLOBDEFS, PRIMS, UTILITY;

#include "macro.p"
begin
  MACRO;
end.